Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/AA_make
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/AA_make	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/AA_make	(revision 55)
@@ -0,0 +1,31 @@
+#- $Id$
+all : libparallel libparameters liborglob libstomate libsechiba
+
+libparameters :
+	(cd src_parameters ; $(M_K) -f Makefile)
+
+libparallel :
+	(cd ../../modeles/ORCHIDEE/src_parallel ; $(M_K) -f Makefile)
+
+liborglob :
+	(cd src_global ; $(M_K) -f Makefile)
+
+libstomate :
+	(cd src_stomate ; $(M_K) -f Makefile)
+
+libsechiba :
+	(cd src_sechiba ; $(M_K) -f Makefile)
+
+config : 
+	(cd src_parameters; $(M_K) -f Makefile config)
+	(cd src_sechiba; $(M_K) -f Makefile config)
+	(cd src_stomate; $(M_K) -f Makefile config)
+
+clean : 
+	(cd src_parameters; $(M_K) -f Makefile clean)
+	(cd src_parallel; $(M_K) -f Makefile clean)
+	(cd src_global; $(M_K) -f Makefile clean)
+	(cd src_sechiba; $(M_K) -f Makefile clean)
+	(cd src_stomate; $(M_K) -f Makefile clean)
+
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/AA_make.ldef
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/AA_make.ldef	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/AA_make.ldef	(revision 55)
@@ -0,0 +1,3 @@
+#- $Id$
+#---------------------------------------------------------------------
+#-
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/Doxyfile_ORCHIDEE
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/Doxyfile_ORCHIDEE	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/Doxyfile_ORCHIDEE	(revision 55)
@@ -0,0 +1,248 @@
+# Doxyfile 1.5.5
+
+#---------------------------------------------------------------------------
+# Project related configuration options
+#---------------------------------------------------------------------------
+DOXYFILE_ENCODING      = ISO-8859-1
+PROJECT_NAME           = ORCHIDEE
+PROJECT_NUMBER         = 1.9.4_AR5
+OUTPUT_DIRECTORY       = ./docs/
+CREATE_SUBDIRS         = YES
+OUTPUT_LANGUAGE        = English
+BRIEF_MEMBER_DESC      = YES
+REPEAT_BRIEF           = YES
+ABBREVIATE_BRIEF       = "The $name class" \
+                         "The $name widget" \
+                         "The $name file" \
+                         is \
+                         provides \
+                         specifies \
+                         contains \
+                         represents \
+                         a \
+                         an \
+                         the
+ALWAYS_DETAILED_SEC    = YES
+INLINE_INHERITED_MEMB  = NO
+FULL_PATH_NAMES        = YES
+STRIP_FROM_PATH        = ./ ../ORCHIDEE_OL/
+STRIP_FROM_INC_PATH    = 
+SHORT_NAMES            = NO
+JAVADOC_AUTOBRIEF      = NO
+QT_AUTOBRIEF           = NO
+MULTILINE_CPP_IS_BRIEF = NO
+INHERIT_DOCS           = YES
+SEPARATE_MEMBER_PAGES  = NO
+TAB_SIZE               = 8
+ALIASES                = 
+OPTIMIZE_OUTPUT_FOR_C  = NO
+OPTIMIZE_OUTPUT_JAVA   = NO
+OPTIMIZE_FOR_FORTRAN   = YES
+OPTIMIZE_OUTPUT_VHDL   = NO
+BUILTIN_STL_SUPPORT    = NO
+CPP_CLI_SUPPORT        = NO
+SIP_SUPPORT            = NO
+DISTRIBUTE_GROUP_DOC   = NO
+SUBGROUPING            = YES
+TYPEDEF_HIDES_STRUCT   = NO
+#---------------------------------------------------------------------------
+# Build related configuration options
+#---------------------------------------------------------------------------
+EXTRACT_ALL            = YES
+EXTRACT_PRIVATE        = YES
+EXTRACT_STATIC         = YES
+EXTRACT_LOCAL_CLASSES  = YES
+EXTRACT_LOCAL_METHODS  = NO
+EXTRACT_ANON_NSPACES   = NO
+HIDE_UNDOC_MEMBERS     = NO
+HIDE_UNDOC_CLASSES     = NO
+HIDE_FRIEND_COMPOUNDS  = NO
+HIDE_IN_BODY_DOCS      = NO
+INTERNAL_DOCS          = NO
+CASE_SENSE_NAMES       = YES
+HIDE_SCOPE_NAMES       = NO
+SHOW_INCLUDE_FILES     = YES
+INLINE_INFO            = YES
+SORT_MEMBER_DOCS       = YES
+SORT_BRIEF_DOCS        = NO
+SORT_GROUP_NAMES       = YES
+SORT_BY_SCOPE_NAME     = NO
+GENERATE_TODOLIST      = YES
+GENERATE_TESTLIST      = YES
+GENERATE_BUGLIST       = YES
+GENERATE_DEPRECATEDLIST= YES
+ENABLED_SECTIONS       = 
+MAX_INITIALIZER_LINES  = 30
+SHOW_USED_FILES        = YES
+SHOW_DIRECTORIES       = YES
+FILE_VERSION_FILTER    = 
+#---------------------------------------------------------------------------
+# configuration options related to warning and progress messages
+#---------------------------------------------------------------------------
+QUIET                  = NO
+WARNINGS               = YES
+WARN_IF_UNDOCUMENTED   = YES
+WARN_IF_DOC_ERROR      = YES
+WARN_NO_PARAMDOC       = YES
+WARN_FORMAT            = "$file:$line: $text"
+WARN_LOGFILE           = 
+#---------------------------------------------------------------------------
+# configuration options related to the input files
+#---------------------------------------------------------------------------
+INPUT                  = ./ ../ORCHIDEE_OL/ ../IOIPSL/src/
+INPUT_ENCODING         = UTF-8
+FILE_PATTERNS          = *.f90 *.F90 *.h
+RECURSIVE              = YES
+EXCLUDE                = 
+EXCLUDE_SYMLINKS       = NO
+EXCLUDE_PATTERNS       = 
+EXCLUDE_SYMBOLS        = 
+EXAMPLE_PATH           = 
+EXAMPLE_PATTERNS       = *
+EXAMPLE_RECURSIVE      = NO
+IMAGE_PATH             = DOC/
+INPUT_FILTER           = 
+FILTER_PATTERNS        = 
+FILTER_SOURCE_FILES    = NO
+#---------------------------------------------------------------------------
+# configuration options related to source browsing
+#---------------------------------------------------------------------------
+SOURCE_BROWSER         = YES
+INLINE_SOURCES         = YES
+STRIP_CODE_COMMENTS    = YES
+REFERENCED_BY_RELATION = YES
+REFERENCES_RELATION    = YES
+REFERENCES_LINK_SOURCE = YES
+USE_HTAGS              = NO
+VERBATIM_HEADERS       = YES
+#---------------------------------------------------------------------------
+# configuration options related to the alphabetical class index
+#---------------------------------------------------------------------------
+ALPHABETICAL_INDEX     = YES
+COLS_IN_ALPHA_INDEX    = 3
+IGNORE_PREFIX          = 
+#---------------------------------------------------------------------------
+# configuration options related to the HTML output
+#---------------------------------------------------------------------------
+GENERATE_HTML          = YES
+HTML_OUTPUT            = html
+HTML_FILE_EXTENSION    = .html
+HTML_HEADER            = 
+HTML_FOOTER            = 
+HTML_STYLESHEET        = 
+HTML_ALIGN_MEMBERS     = YES
+GENERATE_HTMLHELP      = NO
+GENERATE_DOCSET        = NO
+DOCSET_FEEDNAME        = "Doxygen generated docs"
+DOCSET_BUNDLE_ID       = org.doxygen.Project
+HTML_DYNAMIC_SECTIONS  = YES
+CHM_FILE               = 
+HHC_LOCATION           = 
+GENERATE_CHI           = NO
+BINARY_TOC             = YES
+TOC_EXPAND             = YES
+DISABLE_INDEX          = NO
+ENUM_VALUES_PER_LINE   = 4
+GENERATE_TREEVIEW      = YES
+TREEVIEW_WIDTH         = 250
+#---------------------------------------------------------------------------
+# configuration options related to the LaTeX output
+#---------------------------------------------------------------------------
+GENERATE_LATEX         = YES
+LATEX_OUTPUT           = latex
+LATEX_CMD_NAME         = latex
+MAKEINDEX_CMD_NAME     = makeindex
+COMPACT_LATEX          = NO
+PAPER_TYPE             = a4wide
+EXTRA_PACKAGES         = indentfirst
+LATEX_HEADER           = 
+PDF_HYPERLINKS         = YES
+USE_PDFLATEX           = YES
+LATEX_BATCHMODE        = YES
+LATEX_HIDE_INDICES     = NO
+#---------------------------------------------------------------------------
+# configuration options related to the RTF output
+#---------------------------------------------------------------------------
+GENERATE_RTF           = NO
+RTF_OUTPUT             = rtf
+COMPACT_RTF            = NO
+RTF_HYPERLINKS         = NO
+RTF_STYLESHEET_FILE    = 
+RTF_EXTENSIONS_FILE    = 
+#---------------------------------------------------------------------------
+# configuration options related to the man page output
+#---------------------------------------------------------------------------
+GENERATE_MAN           = NO
+MAN_OUTPUT             = man
+MAN_EXTENSION          = .3
+MAN_LINKS              = NO
+#---------------------------------------------------------------------------
+# configuration options related to the XML output
+#---------------------------------------------------------------------------
+GENERATE_XML           = NO
+XML_OUTPUT             = xml
+XML_SCHEMA             = 
+XML_DTD                = 
+XML_PROGRAMLISTING     = YES
+#---------------------------------------------------------------------------
+# configuration options for the AutoGen Definitions output
+#---------------------------------------------------------------------------
+GENERATE_AUTOGEN_DEF   = NO
+#---------------------------------------------------------------------------
+# configuration options related to the Perl module output
+#---------------------------------------------------------------------------
+GENERATE_PERLMOD       = NO
+PERLMOD_LATEX          = NO
+PERLMOD_PRETTY         = YES
+PERLMOD_MAKEVAR_PREFIX = 
+#---------------------------------------------------------------------------
+# Configuration options related to the preprocessor   
+#---------------------------------------------------------------------------
+ENABLE_PREPROCESSING   = YES
+MACRO_EXPANSION        = NO
+EXPAND_ONLY_PREDEF     = NO
+SEARCH_INCLUDES        = NO
+INCLUDE_PATH           = 
+INCLUDE_FILE_PATTERNS  = 
+PREDEFINED             = 
+EXPAND_AS_DEFINED      = 
+SKIP_FUNCTION_MACROS   = YES
+#---------------------------------------------------------------------------
+# Configuration::additions related to external references   
+#---------------------------------------------------------------------------
+TAGFILES               = 
+GENERATE_TAGFILE       = ORCHIDEE_tags
+ALLEXTERNALS           = NO
+EXTERNAL_GROUPS        = YES
+PERL_PATH              = /usr/bin/perl
+#---------------------------------------------------------------------------
+# Configuration options related to the dot tool   
+#---------------------------------------------------------------------------
+CLASS_DIAGRAMS         = YES
+MSCGEN_PATH            = 
+HIDE_UNDOC_RELATIONS   = NO
+HAVE_DOT               = YES
+CLASS_GRAPH            = YES
+COLLABORATION_GRAPH    = YES
+GROUP_GRAPHS           = YES
+UML_LOOK               = NO
+TEMPLATE_RELATIONS     = NO
+INCLUDE_GRAPH          = YES
+INCLUDED_BY_GRAPH      = YES
+CALL_GRAPH             = YES
+CALLER_GRAPH           = YES
+GRAPHICAL_HIERARCHY    = YES
+DIRECTORY_GRAPH        = YES
+DOT_IMAGE_FORMAT       = png
+DOT_PATH               = 
+DOTFILE_DIRS           = 
+DOT_GRAPH_MAX_NODES    = 50
+MAX_DOT_GRAPH_DEPTH    = 1000
+DOT_TRANSPARENT        = YES
+DOT_MULTI_TARGETS      = NO
+GENERATE_LEGEND        = YES
+DOT_CLEANUP            = YES
+#---------------------------------------------------------------------------
+# Configuration::additions related to the search engine   
+#---------------------------------------------------------------------------
+SEARCHENGINE           = YES
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/ORCHIDEE_CeCILL.LIC
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/ORCHIDEE_CeCILL.LIC	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/ORCHIDEE_CeCILL.LIC	(revision 55)
@@ -0,0 +1,40 @@
+The following licence information concerns ONLY the ORCHIDEE MODEL
+==================================================================
+
+Copyright © Centre National de la Recherche Scientifique CNRS  
+            Commissariat à l'Énergie Atomique CEA
+
+ORCHIDEE : Organizing Carbon and Hydrology In Dynamic EcosystEms. 
+
+The purpose of this software is to simulate a number of exchanges
+occurring at the interface between the continental biosphere and the
+atmosphere, as well as the state of the biosphere (soil water and
+carbon content, living biomass, fluxes of latent, sensible heat, net
+CO2 flux, .....). It includes physical, biogeochemical and chemical
+processes at varying time scales (minutes to centuries).
+
+This software is governed by the CeCILL  license under French law and
+abiding by the rules of distribution of free software.  You can  use, 
+modify and/ or redistribute the software under the terms of the CeCILL
+license as circulated by CEA, CNRS and INRIA at the following URL
+"http://www.cecill.info". 
+
+As a counterpart to the access to the source code and  rights to copy,
+modify and redistribute granted by the license, users are provided only
+with a limited warranty  and the software's author,  the holder of the
+economic rights,  and the successive licensors  have only  limited
+liability. 
+
+In this respect, the user's attention is drawn to the risks associated
+with loading,  using,  modifying and/or developing or reproducing the
+software by the user in light of its specific status of free software,
+that may mean  that it is complicated to manipulate,  and  that  also
+therefore means  that it is reserved for developers  and  experienced
+professionals having in-depth computer knowledge. Users are therefore
+encouraged to load and test the software's suitability as regards their
+requirements in conditions enabling the security of their systems and/or 
+data to be ensured and,  more generally, to use and operate it in the 
+same conditions as regards security. 
+
+The fact that you are presently reading this means that you have had
+knowledge of the CeCILL license and that you accept its terms.
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-MPI.fcm
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-MPI.fcm	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-MPI.fcm	(revision 55)
@@ -0,0 +1,17 @@
+%AR                  ar
+%MAKE                gmake
+%FPP                 cpp
+%COMPILER            /usr/local/bin/mpif90 
+%LINKER              /usr/local/bin/mpif90 
+%BASE_FFLAGS         -c -i4 -r8 -fno-second-underscore
+%PROD_FFLAGS         -O3
+%DEV_FFLAGS          -freal=nan -fstatic
+%DEBUG_FFLAGS        -g -fbounds-check -fstatic -ftrace=full
+%FPP_FLAGS           -C -P
+%FPP_DEF
+%LD_BASE             -g
+%MPI_FFLAGS          
+%MPI_LD              
+%OMP_FFLAGS          
+%OMP_LD              
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-MPI.path
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-MPI.path	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-MPI.path	(revision 55)
@@ -0,0 +1,4 @@
+set NETCDF_LIBDIR=/usr/local/lib/NCdF/g95/lib
+set NETCDF_INCDIR=/usr/local/lib/NCdF/g95/include
+set IOIPSL_INCDIR=../../IOIPSL/src
+set IOIPSL_LIBDIR=../../../lib
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-SX8_MERCURE.fcm
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-SX8_MERCURE.fcm	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-SX8_MERCURE.fcm	(revision 55)
@@ -0,0 +1,16 @@
+%AR                  sxar
+%MAKE                make
+%COMPILER            sxmpif90
+%LINKER              sxmpif90
+%BASE_FFLAGS         -P stack -dw -size_t64 -EP -R5 -float0 -Wf,"-A dbl4,-ptr byte,-pvctl res=whole loopcnt=999999 fullmsg noassume"
+%PROD_FFLAGS         -C vopt 
+%DEV_FFLAGS          -C vsafe -gv -Wf,-init stack=nan,-init heap=nan
+%DEBUG_FFLAGS        -C debug -gv -Wf,-init stack=nan,-init heap=nan
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM _OPENMP 
+%LD_BASE             -size_t64 -lblas
+%MPI_FFLAGS          " "
+%MPI_LD              " "
+%OMP_FFLAGS          -P openmp
+%OMP_LD              -P openmp  -Wl,"-ZL 8G"
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-SX8_MERCURE.path
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-SX8_MERCURE.path	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/arch/arch-SX8_MERCURE.path	(revision 55)
@@ -0,0 +1,4 @@
+set NETCDF_LIBDIR=/usr/local/SX8/soft/netcdf/lib
+set NETCDF_INCDIR=/usr/local/SX8/soft/netcdf/include
+set IOIPSL_INCDIR=$WORKDIR/IOIPSL_MPP/src
+set IOIPSL_LIBDIR=$WORKDIR/IOIPSL_MPP/src
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/makeorchidee_fcm
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/makeorchidee_fcm	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/makeorchidee_fcm	(revision 55)
@@ -0,0 +1,197 @@
+#!/bin/csh
+set verbose echo
+set is_parallel_opt       = FALSE
+set is_driver_opt         = FALSE
+set is_arch_opt           = FALSE 
+set is_compile_opt        = FALSE
+set default_compile_flags = "%PROD_FFLAGS"
+set fcm_path=none
+
+top:
+if ($#argv > 0) then
+    switch ($1)
+
+    case -h
+
+########################################################################
+# Manuel en ligne
+########################################################################
+more <<eod
+
+
+makeorchidee_fcm [Options] 
+
+[ -parallel|-p PARALLEL_TYPE ] : activate parallelization with 3 options : 
+    PARALLEL_TYPE =
+    ( mpi | MPI )  : use Message Passing Interface standard
+    ( omp | OMP )  : use OpenMP standard
+    ( mpi_omp | MPI_OMP ) : use both MPI and OpenMP
+
+[ -driver ] : compilation of ORCHIDEE driver if equal TRUE
+
+[ -a|-arch ARCHitecture ] : if TRUE, change architecture for ARCHitecture
+
+[ -prod ] : compilation for production (all optimization)
+
+[ -dev ] : compilation for development (low optimization and -g)
+
+[ -d|-debug ] : compilation for debugging (no optmization and all debug options)
+
+[-fcm_path path]           : path for fcm (default: the default fcm path in environment)
+
+[ -doc ] : generate documentation with Doxygen
+
+eod
+exit
+
+########################################################################
+# Lecture des differentes options
+########################################################################
+
+    case -parallel
+        set is_parallel_opt = TRUE
+        set parallel=$2 ; shift ; shift ; goto top
+
+    case -p
+        set is_parallel_opt = TRUE
+        set parallel=$2 ; shift ; shift ; goto top
+                        
+    case -driver
+        set is_driver_opt = TRUE
+        shift ; goto top
+
+    case -a
+    case -arch
+        set is_arch_opt = TRUE
+        set arch="$2" ; shift ; shift ; goto top
+
+    case -prod
+        set is_compile_opt = TRUE
+        set compile_flags="%PROD_FFLAGS"
+        shift ; goto top
+
+    case -dev
+        set is_compile_opt = TRUE
+        set compile_flags="%DEV_FFLAGS"
+        shift ; goto top
+
+    case -d
+    case -debug
+        set is_compile_opt = TRUE
+        set compile_flags="%DEBUG_FFLAGS"
+        shift ; goto top
+
+    case -fcm_path
+       set fcm_path=$2 ; shift ; shift ; goto top
+
+    case -doc
+       doxygen Doxyfile_ORCHIDEE ; exit 0
+
+    default
+        echo "unknown option "$1" , exiting..."
+        exit 
+   endsw
+endif
+
+###############################################################
+# mettre le chemin du fcm dans le path
+###############################################################
+if  ( "$fcm_path" != 'none' ) then
+    setenv PATH ${fcm_path}:${PATH}
+endif
+
+echo "Chemin du fcm utlise :" 
+which fcm
+
+
+#define architecture files
+if ( $is_arch_opt == TRUE) then
+  if ( -e arch/arch-${arch}.fcm ) then
+    rm -f arch.fcm
+    ln -s arch/arch-${arch}.fcm arch.fcm
+  else
+    echo "architecture file : << arch/arch-${arch}.fcm >> is missing, exiting...."
+    exit
+  endif
+  
+  if ( -e arch/arch-${arch}.path ) then
+    rm -f arch.path
+    ln -s arch/arch-${arch}.path arch.path
+  else
+    echo "architecture file : << arch/arch-${arch}.path >> is missing, exiting...."
+    exit
+  endif
+else
+  echo "Warning : architecture not specified, taking default file <<arch.fcm>> and <<arch.path>>" 
+  if ( ! -e arch.fcm ) then
+    echo "architecture file : << arch.fcm >> is missing, exiting...."
+    exit
+  endif
+
+  if ( ! -e arch.fcm ) then
+    echo "architecture file : << arch.path >> is missing, exiting...."
+    exit
+  endif
+endif
+  
+# set compiler flags
+set FFLAGS="%BASE_FFLAGS"
+set LD_FFLAGS="%LD_BASE"
+set CPP_KEY="%FPP_DEF"
+
+# set compiler flags for optimisation
+if ( $is_compile_opt == FALSE ) then
+  set compile_flags=$default_compile_flags
+endif
+set FFLAGS=${FFLAGS}" "$compile_flags
+
+# set compiler flags for parallelism
+if ( $is_parallel_opt == TRUE ) then
+  echo $parallel 
+  switch ($parallel)
+    case mpi
+    case MPI
+      set FFLAGS="${FFLAGS} %MPI_FFLAGS"
+      set LD_FFLAGS="%MPI_LD ${LD_FFLAGS}"
+      set CPP_KEY="CPP_PARA ${CPP_KEY}"
+      breaksw
+    case omp
+    case OMP
+      set FFLAGS="${FFLAGS} %OMP_FFLAGS"
+      set LD_FFLAGS="%OMP_LD ${LD_FFLAGS}"
+      set CPP_KEY="CPP_OMP CPP_PARA ${CPP_KEY}"
+      breaksw
+    case mpi_omp
+    case MPI_OMP
+      set FFLAGS="${FFLAGS} %MPI_FFLAGS %OMP_FFLAGS"
+      set LD_FFLAGS="%MPI_LD %OMP_LD ${LD_FFLAGS}"
+      set CPP_KEY="CPP_OMP CPP_PARA ${CPP_KEY}"
+      breaksw
+    
+    default
+        echo "unknown option for parallelism :$parallel , only <<mpi>>, <<MPI>> or <<omp>>, <<OMP>> or <<mpi_omp>> <<MPI_OMP>> allowed , exiting..."
+        exit 
+   endsw
+endif
+       
+# set target
+set TARGET = liborchidee.a
+if ( $is_driver_opt == TRUE) then
+  set TARGET="liborchidee_ol.a dim2_driver.exe teststomate.exe forcesoil.exe"
+endif
+
+source ./arch.path
+
+# build config file
+set config_fcm="config.fcm"
+rm -f $config_fcm
+
+echo "%FFLAGS        $FFLAGS"                           >  $config_fcm 
+echo "%CPP_KEY       $CPP_KEY"                          >> $config_fcm
+echo "%EXEC          $TARGET"                           >> $config_fcm
+echo "%LD_FFLAGS     $LD_FFLAGS"                        >> $config_fcm
+echo "%INCDIR        -I$NETCDF_INCDIR -I$IOIPSL_INCDIR" >> $config_fcm
+echo "%LIBDIR        -L$NETCDF_LIBDIR -L$IOIPSL_LIBDIR" >> $config_fcm
+
+
+fcm build
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/AA_make
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/AA_make	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/AA_make	(revision 55)
@@ -0,0 +1,64 @@
+#-
+#- $Id$
+#-
+PARAM_LIB = $(LIBDIR)/libparameters.a
+SXPARAM_LIB = $(PARAM_LIB)
+#-Q- sxnec  SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx6nec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- eshpux SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-
+MODS1 = grid.f90           \
+        solar.f90          \
+	interpol_help.f90
+OBJSMODS1 = $(MODS1:.f90=.o)
+#-
+.PRECIOUS : $(MODEL_LIB)
+#-Q- sxnec  .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
+#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
+#-
+all:
+	$(M_K) libparallel
+	$(M_K) libparameters
+	$(M_K) m_all
+	@echo orglob is OK
+
+m_all: $(MODEL_LIB)($(OBJSMODS1))
+
+libparallel:
+	(cd ../src_parallel; $(M_K) -f Makefile)
+
+libparameters:
+	(cd ../src_parameters; $(M_K) -f Makefile)
+
+$(MODEL_LIB)(%.o) : %.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
+	$(A_C) $(MODEL_LIB) $*.o
+#-Q- sxnec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sxnec 	mv $*.mod $(MODDIR)
+#-Q- sx6nec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx6nec 	mv $*.mod $(MODDIR)
+#-Q- eshpux 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- eshpux 	mv $*.mod $(MODDIR)
+#-Q- sx8mercure 	mv $*.mod $(MODDIR)
+#-Q- sx9mercure 	mv $*.mod $(MODDIR)
+#-Q- sx8brodie	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx8brodie	mv $*.mod $(MODDIR)
+#-Q- solaris 	mv $*.mod $(MODDIR)
+	$(RM) $*.o
+
+config : 
+	$(BINDIR)/Fparser -name ORGLOB $(MODS1)
+	echo 'Configuration of ORGLOB done'
+
+clean:
+	$(RM) $(MODEL_LIB)
+
+$(MODEL_LIB)(grid.o): \
+  $(PARAM_LIB)(constantes.o)
+
+$(MODEL_LIB)(interpol_help.o): \
+  $(PARAM_LIB)(constantes_veg.o)
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/AA_make.ldef
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/AA_make.ldef	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/AA_make.ldef	(revision 55)
@@ -0,0 +1,18 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a ORGLOB
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+MODEL_LIB = $(LIBDIR)/liborglob.a
+SXMODEL_LIB = $(MODEL_LIB)
+#-Q- sxnec  SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxorglob.a
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/grid.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/grid.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/grid.f90	(revision 55)
@@ -0,0 +1,548 @@
+
+!! This module define variables for the grid to gathered points.
+!!
+!! @call sechiba_main
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!!
+!! @author Marie-Alice Foujols, Jan Polcher and Martial Mancip
+!! 
+!!
+!f90doc MODULEgrid
+MODULE grid
+
+  USE defprec
+  USE constantes
+  USE parallel
+
+  IMPLICIT NONE
+
+  !
+  ! PARAMETERS
+  ! default resolution (m)
+  REAL(r_std), PARAMETER :: default_resolution = 250000.
+  !
+  ! VARIABLES
+  !
+  ! Global map or not.
+  ! There is little change that if iim <=2 and jjm <= 2 that we have global grid.
+  ! Furthermore using the second line allows to avoid pole problems for global grids
+  LOGICAL, SAVE                                      :: global = .FALSE.
+  !
+  !-
+  !- Variable to help describe the grid
+  !- once the points are gathered.
+  !-
+  !! Limits of the domain
+  REAL(r_std), SAVE                                   :: limit_west, limit_east, &
+       &                                                limit_north, limit_south
+  !-
+  !! Geographical coordinates
+  REAL(r_std), ALLOCATABLE, DIMENSION (:,:), SAVE     :: lalo
+  !! index  of land points
+  INTEGER, ALLOCATABLE, DIMENSION (:), SAVE          :: ilandindex,jlandindex
+  !- 
+  !! Fraction of continents.
+  REAL(r_std), ALLOCATABLE, DIMENSION (:), SAVE       :: contfrac
+  !
+  ! indices of the 4 neighbours of each grid point (1=N, 2=E, 3=S, 4=W)
+  !   a zero or negative index means that this neighbour is not a land point
+  INTEGER(i_std), ALLOCATABLE, DIMENSION (:,:), SAVE :: neighbours
+  !
+  ! resolution at each grid point in m (1=E-W, 2=N-S)
+  ! (size in x an y of the grid)
+  REAL(r_std), ALLOCATABLE, DIMENSION (:,:), SAVE     :: resolution
+  REAL(r_std), DIMENSION(2), SAVE :: min_resol,max_resol
+  REAL(r_std), ALLOCATABLE, DIMENSION (:), SAVE     :: area
+  !
+  !
+  ! Get the direction of the grid
+  !
+  CHARACTER(LEN=2), DIMENSION(2), SAVE, PRIVATE      :: grid_dir
+  !
+  ! Rose gives the geographical direction for the various index increments
+  ! The following corespondences exist
+  !                       WE&NS  WE&SN and so on !
+  ! rose(1) = i+0 & j-1    NN     SS
+  ! rose(2) = i+1 & j-1    NE     SE
+  ! rose(3) = i+1 & j+0    EE     EE
+  ! rose(4) = i+1 & j+1    SE     NE
+  ! rose(5) = i+0 & j+1    SS     NN
+  ! rose(6) = i-1 & j+1    SW     NW
+  ! rose(7) = i-1 & j+0    WW     WW
+  ! rose(8) = i-1 & j-1    NW     SW
+  INTEGER(i_std), DIMENSION(8), SAVE, PRIVATE        :: rose
+  !
+  ! The calendar
+  CHARACTER(LEN=20), SAVE         :: calendar_str
+  !
+  ! The date
+  REAL(r_std)                     :: in_julian
+  ! Diff with day 0
+  REAL(r_std)                     :: julian_diff
+  !
+  INTEGER(i_std)                  :: year, month, day
+  REAL(r_std)                     :: sec
+  !
+  ! month_len (d)
+  INTEGER(i_std)                  :: month_len
+  !
+  ! year length (d)
+  INTEGER(i_std), SAVE            :: year_length=0
+  !
+  ! Ration between calendar year in days (ie 360d or 365d ...) to gregorian year length 
+  REAL(r_std) :: year_spread
+  !
+CONTAINS
+  !
+  !f90doc CONTAINS
+  ! 
+  !
+  SUBROUTINE init_grid ( npts )
+    !
+    ! 0 interface
+    !
+    IMPLICIT NONE
+    !
+    ! 0.1 input  !
+    
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                 :: npts !! Number of local continental points 
+    !
+    !  Create the internal coordinate table
+    !
+    IF ( (.NOT.ALLOCATED(lalo))) THEN
+       ALLOCATE(lalo(npts,2))
+       lalo(:,:) = val_exp
+    ENDIF
+    !-
+    !- Store variable to help describe the grid
+    !- once the points are gathered.
+    !-
+    IF ( (.NOT.ALLOCATED(neighbours))) THEN
+       ALLOCATE(neighbours(npts,8))
+       neighbours(:,:) = -999999
+    ENDIF
+    IF ( (.NOT.ALLOCATED(resolution))) THEN
+       ALLOCATE(resolution(npts,2))
+       resolution(:,:) = val_exp
+    ENDIF
+    IF ( (.NOT.ALLOCATED(area))) THEN
+       ALLOCATE(area(npts))
+       area(:) = val_exp
+    ENDIF
+    !
+    !- Store the fraction of the continents only once so that the user
+    !- does not change them afterwards.
+    !
+    IF ( (.NOT.ALLOCATED(contfrac))) THEN
+       ALLOCATE(contfrac(npts))
+       contfrac(:) = val_exp
+    ENDIF
+    !
+    ! Allocation of index coordinates
+    IF (.NOT. ALLOCATED(ilandindex)) THEN
+       ALLOCATE(ilandindex(npts),jlandindex(npts))
+       ilandindex(:) = -10000000
+       jlandindex(:) = -10000000
+    ENDIF
+    !
+  END SUBROUTINE init_grid
+
+  SUBROUTINE grid_stuff (npts_glo, iim, jjm, grid_lon, grid_lat, kindex)
+    !
+    ! 0 interface
+    !
+    IMPLICIT NONE
+    !
+    ! 0.1 input  !
+    
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                 :: npts_glo
+    ! Size of cartesian grid
+    INTEGER(i_std), INTENT(in)                                 :: iim, jjm
+    ! Longitudes on cartesian grid
+    REAL(r_std), DIMENSION(iim,jjm), INTENT(in)                 :: grid_lon
+    ! Latitudes on cartesian grid
+    REAL(r_std), DIMENSION(iim,jjm), INTENT(in)                 :: grid_lat
+    ! Index of land point on 2D map (in local position)
+    INTEGER(i_std), DIMENSION(:), INTENT(in)                :: kindex    
+    !
+    ! 0.3 local
+    !
+    ! Index of land point on 2D map (in global position)
+    INTEGER, ALLOCATABLE, DIMENSION (:)                        :: index_p
+    !
+    ! which STOMATE point corresponds to the given point on the cartesian grid
+    INTEGER(i_std), DIMENSION(iim,jjm)                   :: correspondance
+    ! cosine of the latitude
+    REAL(r_std)                                           :: coslat
+    ! number of points where default resolution is used
+    INTEGER(i_std)                                       :: ndefault_lon, ndefault_lat
+    ! Indices
+    INTEGER(i_std)                                       :: i,ip,jp, imm1, imp1, imm1l, imp1l, ii
+    !
+    INTEGER(i_std), SAVE                           :: bavard=2
+    REAL(r_std), PARAMETER                          :: min_stomate = 1.E-8
+    REAL(r_std), SAVE                               :: pi
+    
+    ! =========================================================================
+    
+    pi = 4. * ATAN(1.)
+
+    IF ( bavard .GE. 4 ) WRITE(numout,*) 'Entering grid_stuff'
+
+    ! default resolution
+    IF ( bavard .GT. 1 ) WRITE(numout,*) 'grid stuff: default resolution (m): ',default_resolution
+    !
+    !-
+    IF (is_root_prc) THEN
+       ! Check if we have a global map or not.
+       ! There is little change that if iim <=2 and jjm <= 2 that we have global grid.
+       ! Furthermore using the second line allows to avoid pole problems for global grids
+       IF (iim <= 2 .OR. jjm <= 2) THEN
+          global = .FALSE.
+       ELSE
+          ! We assume here that the longitude is in increasing order and in degrees.
+          IF ( grid_lon(iim,2)-grid_lon(1,2) >= 360. - (grid_lon(2,2)-grid_lon(1,2)) ) THEN
+             global = .TRUE.
+          ENDIF
+       ENDIF
+       !
+       ! Get the direction of the grid
+       !
+       IF ( iim > 1 ) THEN
+          IF ( grid_lon(1,1) <= grid_lon(2,1) ) THEN
+             grid_dir(1) = 'WE'
+          ELSE
+             grid_dir(1) = 'EW'
+          ENDIF
+       ELSE
+          grid_dir(1) = 'WE'
+       ENDIF
+       !
+       IF ( jjm > 1 ) THEN
+          IF ( grid_lat(1,1) >= grid_lat(1,2) ) THEN
+             grid_dir(2) = 'NS'
+          ELSE
+             grid_dir(2) = 'SN'
+          ENDIF
+       ELSE
+          grid_dir(2) = 'NS'
+       ENDIF
+       !
+       !! WRITE(numout,*) 'Longitude direction :', grid_dir(1)
+       !! WRITE(numout,*) 'Latitude  direction :', grid_dir(2)
+       !
+       ndefault_lon = 0
+       ndefault_lat = 0
+       ! initialize output
+       neighbours_g(:,:) = -1
+       resolution_g(:,:) = zero
+       min_resol(:) = 1.e6
+       max_resol(:) = moins_un
+       
+       correspondance(:,:) = -1
+       DO i = 1, npts_glo          
+          !
+          ! 1 find numbers of the latitude and longitude of each point
+          !
+          
+          ! index of latitude
+          jp = INT( (index_g(i)-1) /iim ) + 1
+          
+          ! index of longitude
+          ip = index_g(i) - ( jp-1 ) * iim
+          !
+          !correspondance(ip,jp) = kindex(i)
+          !
+          correspondance(ip,jp) = i
+
+       ENDDO
+  
+       !
+       ! Get the "wind rose" for the various orientation of the grid
+       !
+       IF ( grid_dir(1) .EQ. 'WE' .AND.  grid_dir(2) .EQ. 'NS' ) THEN
+          rose(1) = 1
+          rose(2) = 2
+          rose(3) = 3
+          rose(4) = 4
+          rose(5) = 5
+          rose(6) = 6
+          rose(7) = 7
+          rose(8) = 8
+       ELSE IF ( grid_dir(1) .EQ. 'EW' .AND.  grid_dir(2) .EQ. 'NS' ) THEN
+          rose(1) = 1
+          rose(2) = 8
+          rose(3) = 7
+          rose(4) = 6
+          rose(5) = 5
+          rose(6) = 4
+          rose(7) = 3
+          rose(8) = 2
+       ELSE IF ( grid_dir(1) .EQ. 'WE' .AND.  grid_dir(2) .EQ. 'SN' ) THEN
+          rose(1) = 5
+          rose(2) = 4
+          rose(3) = 3
+          rose(4) = 2
+          rose(5) = 1
+          rose(6) = 8
+          rose(7) = 7
+          rose(8) = 6
+       ELSE IF ( grid_dir(1) .EQ. 'EW' .AND.  grid_dir(2) .EQ. 'SN' ) THEN
+          rose(1) = 5
+          rose(2) = 6
+          rose(3) = 7
+          rose(4) = 8
+          rose(5) = 1
+          rose(6) = 2
+          rose(7) = 3
+          rose(8) = 4
+       ELSE
+          WRITE(numout,*) 'We can not be here'
+          STOP 'grid_stuff'
+       ENDIF
+
+       DO i = 1, npts_glo
+
+          ! index of latitude
+          jp = INT( (index_g(i)-1) /iim ) + 1
+          
+          ! index of longitude
+          ip = index_g(i) - ( jp-1 ) * iim
+          
+          !
+          ! 2 resolution
+          !
+          
+          !
+          ! 2.1 longitude
+          !
+          
+          ! prevent infinite resolution at the pole
+          coslat = MAX( COS( grid_lat(ip,jp) * pi/180. ), 0.001 )     
+          IF ( iim .GT. 1 ) THEN
+             
+             IF ( ip .EQ. 1 ) THEN
+                resolution_g(i,1) = &
+                     ABS( grid_lon(ip+1,jp) - grid_lon(ip,jp) ) * &
+                     pi/180. * R_Earth * coslat
+             ELSEIF ( ip .EQ. iim ) THEN
+                resolution_g(i,1) = &
+                     ABS( grid_lon(ip,jp) - grid_lon(ip-1,jp) ) * &
+                     pi/180. * R_Earth * coslat
+             ELSE
+                resolution_g(i,1) = &
+                     ABS( grid_lon(ip+1,jp) - grid_lon(ip-1,jp) )/2. *&
+                     pi/180. * R_Earth * coslat
+             ENDIF
+             
+          ELSE
+             
+             resolution_g(i,1) = default_resolution
+             
+             ndefault_lon = ndefault_lon + 1
+
+          ENDIF
+
+          !
+          ! 2.2 latitude
+          !
+          
+          IF ( jjm .GT. 1 ) THEN
+
+             IF ( jp .EQ. 1 ) THEN
+                resolution_g(i,2) = &
+                     ABS( grid_lat(ip,jp) - grid_lat(ip,jp+1) ) * &
+                     pi/180. * R_Earth
+             ELSEIF ( jp .EQ. jjm ) THEN
+                resolution_g(i,2) = &
+                     ABS( grid_lat(ip,jp-1) - grid_lat(ip,jp) ) * &
+                     pi/180. * R_Earth
+             ELSE
+                resolution_g(i,2) = &
+                     ABS( grid_lat(ip,jp-1) - grid_lat(ip,jp+1) )/2. *&
+                     pi/180. * R_Earth
+             ENDIF
+             
+          ELSE
+             
+             resolution_g(i,2) = default_resolution
+             
+             ndefault_lat = ndefault_lat + 1
+             
+          ENDIF
+          min_resol(1) = MIN(resolution_g(i,1),min_resol(1))
+          min_resol(2) = MIN(resolution_g(i,2),min_resol(2))
+          max_resol(1) = MAX(resolution_g(i,1),max_resol(1))
+          max_resol(2) = MAX(resolution_g(i,2),max_resol(2))
+
+          area_g(i) = resolution_g(i,1)*resolution_g(i,2)
+
+          !
+          ! 3 find neighbours 
+          !     
+          imm1 = 0
+          IF ( ip .GT. 1 ) THEN
+             imm1 = ip - 1
+          ELSEIF ( global ) THEN
+             imm1 = iim
+          ENDIF
+          
+          imp1 = 0
+          IF ( ip .LT. iim ) THEN
+             imp1 = ip + 1
+          ELSEIF ( global ) THEN
+             imp1 = 1
+          ENDIF
+          !
+          ! East and West
+          !
+          IF ( imp1 > 0 ) THEN
+             neighbours_g(i,rose(3)) = correspondance(imp1,jp)
+          ELSE
+             neighbours_g(i,rose(3)) = -1
+          ENDIF
+          IF ( imm1 > 0 ) THEN
+             neighbours_g(i,rose(7)) = correspondance(imm1,jp)
+          ELSE
+             neighbours_g(i,rose(7)) = -1
+          ENDIF
+          !
+          ! North
+          !
+          IF ( jp .GT. 1 ) THEN
+
+             neighbours_g(i,rose(1)) = correspondance(ip,jp-1)
+             IF ( imp1 > 0 ) THEN
+                neighbours_g(i,rose(2)) = correspondance(imp1,jp-1)
+             ELSE
+                neighbours_g(i,rose(2)) = -1
+             ENDIF
+             IF ( imm1 > 0 ) THEN
+                neighbours_g(i,rose(8)) = correspondance(imm1,jp-1)
+             ELSE
+                neighbours_g(i,rose(8)) = -1
+             ENDIF
+
+          ELSE
+             IF ( global ) THEN
+                
+                ! special treatment for the pole if we are really in a 2d grid
+                
+                IF ( ( iim .GT. 1 ) .AND. ( jjm .GT. 1 ) ) THEN
+                   !
+                   ii = MOD(ip+iim/2-1,iim)+1
+                   imm1l = ii - 1
+                   IF ( imm1l .LT. 1 ) imm1l = iim
+                   imp1l = ii + 1
+                   IF ( imp1l .GT. iim ) imp1l = 1
+                   !
+                   IF ( ABS( ( grid_lat(ip,jp) ) - 90. ) .LT. min_sechiba ) THEN
+                      ! the grid point sits exactly on the pole. The neighbour is situated
+                   ! at a lower latitude.
+                      neighbours_g(i,rose(1)) = correspondance( ii, jp+1 )
+                      neighbours_g(i,rose(2)) = correspondance( imm1l, jp+1 )
+                      neighbours_g(i,rose(8)) = correspondance( imp1l, jp+1 )
+                   ELSE
+                      ! look across the North Pole
+                      neighbours_g(i,rose(1)) = correspondance( ii, jp )
+                      neighbours_g(i,rose(2)) = correspondance( imm1l, jp )
+                      neighbours_g(i,rose(8)) = correspondance( imp1l, jp )
+                   ENDIF
+                ENDIF
+
+             ELSE
+
+                neighbours_g(i,rose(1)) = -1
+                neighbours_g(i,rose(2)) = -1
+                neighbours_g(i,rose(8)) = -1
+                
+             ENDIF
+
+          ENDIF
+          
+          ! South
+          IF ( jp .LT. jjm ) THEN
+
+             neighbours_g(i,rose(5)) = correspondance(ip,jp+1)
+             IF ( imp1 > 0 ) THEN
+                neighbours_g(i,rose(4)) = correspondance(imp1,jp+1)
+             ELSE
+                neighbours_g(i,rose(4)) = -1
+             ENDIF
+             IF ( imm1 > 0 ) THEN
+                neighbours_g(i,rose(6)) = correspondance(imm1,jp+1)
+             ELSE
+                neighbours_g(i,rose(6)) = -1
+             ENDIF
+
+          ELSE
+             
+             IF ( global ) THEN
+
+                ! special treatment for the pole if we are really in a 2d grid
+                
+                IF ( ( iim .GT. 1 ) .AND. ( jjm .GT. 1 ) ) THEN
+                   !
+                   ii = MOD(ip+iim/2-1,iim)+1
+                   imm1l = ii - 1
+                   IF ( imm1l .LT. 1 ) imm1l = iim
+                   imp1l = ii + 1
+                   IF ( imp1l .GT. iim ) imp1l = 1
+                   !
+                   IF ( ( ABS( grid_lat(ip,jp) ) - 90. ) .LT. min_sechiba ) THEN
+                      ! the grid point sits exactly on the pole. The neighbour is situated
+                      ! at a lower latitude.
+                      neighbours_g(i,rose(5)) = correspondance( ii, jp-1 )
+                      neighbours_g(i,rose(4)) = correspondance( imm1l, jp-1 )
+                      neighbours_g(i,rose(6)) = correspondance( imp1l, jp-1 )
+                   ELSE
+                      ! look across the South Pole
+                      neighbours_g(i,rose(5)) = correspondance( ii, jp )
+                      neighbours_g(i,rose(4)) = correspondance( imm1l, jp )
+                      neighbours_g(i,rose(6)) = correspondance( imp1l, jp )
+                   ENDIF
+                ENDIF
+
+             ELSE
+                
+                neighbours_g(i,rose(5)) = -1
+                neighbours_g(i,rose(4)) = -1
+                neighbours_g(i,rose(6)) = -1
+                
+             ENDIF
+          ENDIF
+
+       ENDDO
+
+       IF ( bavard .GT. 1 ) THEN
+          WRITE(numout,*) '  > Total number of points: ',npts_glo
+          WRITE(numout,*) '  > Using default zonal resolution at',ndefault_lon,' points.'
+          WRITE(numout,*) '  > Using default meridional resolution at',ndefault_lat,' points.'
+       ENDIF
+       !
+    ENDIF ! (root_prc)
+
+    CALL scatter(neighbours_g,neighbours)
+    CALL scatter(resolution_g,resolution)
+    CALL scatter(area_g,area)
+    CALL bcast(min_resol)
+    CALL bcast(max_resol)
+    IF ( bavard .EQ. 5 ) THEN
+       WRITE(numout,*) '  > resolution  = ',resolution
+       WRITE(numout,*) '  > rose = ',rose
+       WRITE(numout,*) '  > neighbours  = ',neighbours
+    ENDIF
+    IF ( bavard .GT. 1 ) WRITE(numout,*) 'Leaving grid_stuff'
+    
+  END SUBROUTINE grid_stuff
+  !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+END MODULE grid
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/interpol_help.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/interpol_help.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/interpol_help.f90	(revision 55)
@@ -0,0 +1,876 @@
+!
+! Aggregation routines. These routines allow to interpolate from the finer grid on which the 
+! surface parameter is available to the coarser one of the model.
+!
+! The routines work for the fine data on a regular lat/lon grid. This grid can come in as either
+! a rank2 array or a vector. Two procedure exist which require slightly different input fields.
+!
+!
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!
+!
+MODULE interpol_help
+
+  ! Modules used :
+  USE IOIPSL,  ONLY : ipslerr
+
+  USE constantes
+  USE constantes_veg
+  USE parallel
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC aggregate, aggregate_p
+  !
+  INTERFACE aggregate
+     MODULE PROCEDURE aggregate_2d, aggregate_vec
+  END INTERFACE
+  !
+  INTERFACE aggregate_p
+     MODULE PROCEDURE aggregate_2d_p, aggregate_vec_p
+  END INTERFACE
+  !
+  REAL(r_std), PARAMETER                          :: mincos  = 0.0001
+  !
+  LOGICAL, PARAMETER                              :: check_grid=.FALSE.
+  !
+CONTAINS
+  !
+  ! This routing will get for each point of the coarse grid the
+  ! indexes of the finer grid and the area of overlap. 
+  ! This routine is designed for a fine grid which is regular in lat/lon.
+  !
+  SUBROUTINE aggregate_2d (nbpt, lalo, neighbours, resolution, contfrac, &
+       &                iml, jml, lon_rel, lat_rel, mask, callsign, &
+       &                incmax, indinc, areaoverlap, ok)
+    !
+    ! INPUT
+    ! 
+    INTEGER(i_std), INTENT(in)   :: nbpt                 ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)         ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)   :: neighbours(nbpt,8)   ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)   ! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)       ! Fraction of land in each grid box.
+    INTEGER(i_std), INTENT(in)   :: iml, jml             ! Size of the finer grid
+    REAL(r_std), INTENT(in)       :: lon_rel(iml, jml)    ! Longitudes for the finer grid
+    REAL(r_std), INTENT(in)       :: lat_rel(iml, jml)    ! Latitudes for the finer grid
+    INTEGER(i_std), INTENT(in)   :: mask(iml, jml)       ! Mask which retains only the significative points
+                                                         ! of the fine grid.
+    CHARACTER(LEN=*), INTENT(in) :: callsign             ! Allows to specify which variable is beeing treated
+    INTEGER(i_std), INTENT(in)    :: incmax              ! Maximum point of the fine grid we can store.
+    !
+    ! Output
+    !
+    INTEGER(i_std), INTENT(out)  :: indinc(nbpt,incmax,2)
+    REAL(r_std), INTENT(out)      :: areaoverlap(nbpt,incmax)
+    LOGICAL, OPTIONAL, INTENT(out)      :: ok            ! return code
+    !
+    ! Local Variables
+    !
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_ful, lon_ful
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: loup_rel, lolow_rel, laup_rel, lalow_rel
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: searchind
+    REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
+    REAL(r_std) :: coslat, ax, ay, sgn, lonrel, lolowrel, louprel
+    INTEGER(i_std) :: fopt, fopt_max, ip, jp, ib, i, itmp, iprog, nbind
+    REAL(r_std) :: domain_minlon,domain_maxlon,domain_minlat,domain_maxlat
+    INTEGER(i_std) :: minLon(1), maxLon(1)
+
+    INTEGER                  :: ALLOC_ERR
+    LOGICAL :: err_fopt
+    err_fopt = .FALSE.
+    !
+    ! Some inital assignmens
+    !
+    areaoverlap(:,:) = moins_un
+    indinc(:,:,:) = zero
+    !
+    ALLOC_ERR=-1
+    ALLOCATE (laup_rel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of laup_rel : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (loup_rel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of loup_rel : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (lalow_rel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lalow_rel : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (lolow_rel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lolow_rel : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (lat_ful(iml+2,jml+2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (lon_ful(iml+2,jml+2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE (searchind(iml*jml,2), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of searchbind : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    IF (PRESENT(ok)) ok = .TRUE.
+    !
+    !    Duplicate the border assuming we have a global grid going from west to east
+    !
+    lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
+    lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
+    !
+    IF ( lon_rel(iml,1) .LT. lon_ful(2,2)) THEN
+       lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
+       lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+    ELSE
+       lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
+       lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+    ENDIF
+
+    IF ( lon_rel(1,1) .GT. lon_ful(iml+1,2)) THEN
+       lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
+       lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+    ELSE
+       lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
+       lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+    ENDIF
+    !
+    sgn = lat_rel(1,1)/ABS(lat_rel(1,1))
+    lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
+    sgn = lat_rel(1,jml)/ABS(lat_rel(1,jml))
+    lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
+    lat_ful(1,1) = lat_ful(iml+1,1)
+    lat_ful(iml+2,1) = lat_ful(2,1)
+    lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
+    lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
+    !
+    ! Add the longitude lines to the top and bottom
+    !
+    lon_ful(:,1) = lon_ful(:,2) 
+    lon_ful(:,jml+2) = lon_ful(:,jml+1) 
+    !
+    !  Get the upper and lower limits of each grid box
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          !
+          loup_rel(ip,jp) =MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
+               & 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+          lolow_rel(ip,jp) =MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
+               & 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+          laup_rel(ip,jp) =MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
+               & 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+          lalow_rel(ip,jp) =MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
+               & 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+          !
+       ENDDO
+    ENDDO
+    IF (check_grid) THEN
+       WRITE(numout,*) "================================"
+       WRITE(numout,*) "interpol_aggrgate_2d : "
+       WRITE(numout,*) "lalo(:,1) :",lalo(:,1)
+       WRITE(numout,*) "lalo(:,2) :",lalo(:,2)
+       WRITE(numout,*) "Map meshes : "
+       WRITE(numout,*) "lat read(1,:) :",lat_rel(1,:)
+       WRITE(numout,*) "lat_ful(1,:) :",lat_ful(1,:)
+       WRITE(numout,*) "lat_ful(2,:) :",lat_ful(2,:)
+       WRITE(numout,*) "lalow_rel(1,:) :",lalow_rel(1,:)
+       WRITE(numout,*) "laup_rel(1,:) :",laup_rel(1,:)
+       WRITE(numout,*) "================================"
+       WRITE(numout,*) "lon read(:,1) :",lon_rel(:,1)
+       WRITE(numout,*) "lon_ful(:,1) :",lon_ful(:,1)
+       WRITE(numout,*) "lon_ful(:,2) :",lon_ful(:,2)
+       WRITE(numout,*) "lolow_rel(:,1) :",lolow_rel(:,1)
+       WRITE(numout,*) "loup_rel(:,1) :",loup_rel(:,1)
+       WRITE(numout,*) "================================"
+    ENDIF
+    !
+    !
+    !  To speedup calculations we will get the limits of the domain of the 
+    !  coarse grid and select all the points of the fine grid which are potentialy
+    !  in this domain.
+    !
+    !
+    minLon = MINLOC(lalo(1:nbpt,2))
+    coslat = MAX(COS(lalo(minLon(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
+    domain_minlon = lalo(minLon(1),2) - resolution(minLon(1),1)/(2.0*coslat)
+    maxLon = MAXLOC(lalo(1:nbpt,2))
+    coslat = MAX(COS(lalo(maxLon(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
+    domain_maxlon = lalo(maxLon(1),2) + resolution(maxLon(1),1)/(2.0*coslat)
+    !
+    coslat = pi/180. * R_Earth
+    domain_minlat = MINVAL(lalo(1:nbpt,1)) - resolution(maxLon(1),2)/(2.0*coslat)
+    domain_maxlat = MAXVAL(lalo(1:nbpt,1)) + resolution(maxLon(1),2)/(2.0*coslat)
+    !
+    IF (check_grid) THEN
+       WRITE(numout,*) "indices min/max of longitude :",minLon,maxLon, &
+            & "; longitude min/max : ",lalo(minLon,1),lalo(maxLon,1)
+       WRITE(numout,*) "Domain for coarse grid :"
+       WRITE(numout,*) '(',domain_minlat,',',domain_minlon,')',&
+   &                   '(',domain_maxlat,',',domain_maxlon,')'
+       WRITE(numout,*) "================================"
+    ENDIF
+    !
+    ! we list a first approximation of all point we will need to 
+    ! scan to fill our coarse grid.
+    !
+    IF ( domain_minlon <= -179.5 .AND. domain_maxlon >= 179.5 .AND. &
+      &  domain_minlat <= -89.5  .AND. domain_maxlat >= 89.5 ) THEN
+       ! Here we do the entire globe
+       nbind=0
+       DO ip=1,iml
+          DO jp=1,jml
+             IF (mask(ip,jp) == 1 ) THEN
+                nbind = nbind + 1
+                searchind(nbind,1) = ip
+                searchind(nbind,2) = jp
+             ENDIF
+          ENDDO
+       ENDDO
+       !
+    ELSE
+       ! Now we get a limited number of points
+       nbind=0
+       DO ip=1,iml
+          DO jp=1,jml
+             IF ( loup_rel(ip,jp) >= domain_minlon .AND. lolow_rel(ip,jp) <= domain_maxlon .AND.&
+               &  laup_rel(ip,jp) >= domain_minlat .AND. lalow_rel(ip,jp) <= domain_maxlat ) THEN
+                IF (mask(ip,jp) == 1 ) THEN
+                   nbind = nbind + 1
+                   searchind(nbind,1) = ip
+                   searchind(nbind,2) = jp
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+    !
+    WRITE(numout,*) 'We will work with ', nbind, ' points of the fine grid'
+    !
+    WRITE(numout,*) 'Aggregate_2d : ', callsign
+#ifdef INTERPOL_ADVANCE
+    WRITE(numout,'(2a40)')'0%--------------------------------------', &
+         & '------------------------------------100%'
+#endif
+    !
+    !   Now we take each grid point and find out which values from the forcing we need to average
+    !
+    fopt_max = -1
+    DO ib =1, nbpt
+       !
+       !   Give a progress meter
+       !
+#ifdef INTERPOL_ADVANCE
+       iprog = NINT(REAL(ib,r_std)/REAL(nbpt,r_std)*79.) - NINT(REAL(ib-1,r_std)/REAL(nbpt,r_std)*79.)
+       IF ( iprog .NE. 0 ) THEN
+          WRITE(numout,'(a1,$)') 'x'
+       ENDIF
+#endif
+       !
+       !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+       !  into longitudes and latitudes we do not have the problem of periodicity.
+       !  coslat is a help variable here !
+       !
+       coslat = MAX(COS(lalo(ib,1) * pi/180. ), mincos )*pi/180. * R_Earth
+       !
+       lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat) 
+       lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+       !
+       coslat = pi/180. * R_Earth
+       !
+       lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat) 
+       lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat) 
+       !
+       !  Find the grid boxes from the data that go into the model's boxes
+       !  We still work as if we had a regular grid ! Well it needs to be localy regular so
+       !  so that the longitude at the latitude of the last found point is close to the one 
+       !  of the next point.
+       !
+       fopt = zero
+       !
+       DO i=1,nbind
+          !
+          ip = searchind(i,1)
+          jp = searchind(i,2)
+          !
+          !  Either the center of the data grid point is in the interval of the model grid or
+          !  the East and West limits of the data grid point are on either sides of the border of
+          !  the data grid.
+          !
+          !  To do that correctly we have to check if the grid box sits on the date-line.
+          !
+          IF ( lon_low < -180.0 ) THEN
+             ! -179 -> -179
+             ! 179 -> -181
+             lonrel = MOD( lon_rel(ip,jp) - 360.0, 360.0)
+             lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
+             louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
+             !
+          ELSE IF ( lon_up > 180.0 ) THEN
+             ! -179 -> 181
+             !  179 -> 179
+             lonrel = MOD( lon_rel(ip,jp) + 360., 360.0)
+             lolowrel = MOD( lolow_rel(ip,jp) + 360., 360.0)
+             louprel = MOD( loup_rel(ip,jp) + 360., 360.0)
+          ELSE
+             lonrel = lon_rel(ip,jp)
+             lolowrel = lolow_rel(ip,jp)
+             louprel = loup_rel(ip,jp)
+          ENDIF
+          !
+          !
+          !
+          IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
+               & lolowrel < lon_low .AND.  louprel > lon_low .OR. &
+               & lolowrel < lon_up  .AND.  louprel > lon_up ) THEN
+             !
+             ! Now that we have the longitude let us find the latitude
+             !
+             IF ( lat_rel(ip,jp) > lat_low .AND. lat_rel(ip,jp) < lat_up .OR. &
+                  & lalow_rel(ip,jp) < lat_low .AND. laup_rel(ip,jp) > lat_low .OR.&
+                  & lalow_rel(ip,jp) < lat_up .AND. laup_rel(ip,jp) > lat_up) THEN
+                   !
+                fopt = fopt + 1
+                IF ( fopt > incmax) THEN
+                   err_fopt=.TRUE.
+                   EXIT
+                ELSE
+                   !
+                   ! If we sit on the date line we need to do the same transformations as above.
+                   ! 
+                   IF ( lon_low < -180.0 ) THEN
+                      lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
+                      louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
+                      !
+                   ELSE IF ( lon_up > 180.0 ) THEN
+                      lolowrel = MOD( lolow_rel(ip,jp) + 360., 360.0)
+                      louprel = MOD( loup_rel(ip,jp) + 360., 360.0)
+                   ELSE
+                      lolowrel = lolow_rel(ip,jp)
+                      louprel = loup_rel(ip,jp)
+                   ENDIF
+                   !
+                   ! Get the area of the fine grid in the model grid
+                   !
+                   coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), mincos )
+                   ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
+                   ay = (MIN(lat_up, laup_rel(ip,jp))-MAX(lat_low,lalow_rel(ip,jp)))*pi/180. * R_Earth
+                   !
+                   areaoverlap(ib, fopt) = ax*ay
+                   indinc(ib, fopt, 1) = ip
+                   indinc(ib, fopt, 2) = jp
+                   !
+                   ! If this point was 100% within the grid then we can de-select it from our
+                   ! list as it can not be in another mesh of the coarse grid.
+                   !
+                   IF ( louprel < lon_up .AND. lolowrel > lon_low .AND. &
+                     &  laup_rel(ip,jp) < lat_up .AND. lalow_rel(ip,jp) > lat_low ) THEN
+                      searchind(i,1) = 0
+                      searchind(i,2) = 0
+                   ENDIF
+                   !
+                ENDIF
+             ENDIF       ! IF lat
+          ENDIF          ! IF lon
+       ENDDO
+
+       IF (err_fopt) THEN
+          WRITE(numout,*) 'Working on variable :', callsign
+          WRITE(numout,*) 'Reached value ', fopt,' for fopt on point', ib
+          CALL ipslerr(2,'aggregate_2d', &
+               'Working on variable :'//callsign, &
+               'Reached incmax value for fopt.',&
+               'Please increase incmax in subroutine calling aggregate')                   
+          IF (PRESENT(ok)) THEN
+             ok = .FALSE.
+             RETURN
+          ELSE
+             STOP "aggregate_2d"
+          ENDIF
+       ENDIF
+       fopt_max = MAX ( fopt, fopt_max )
+       !
+       ! De-select the marked points
+       !
+       itmp = nbind
+       nbind = 0
+       DO i=1,itmp
+          IF ( searchind(i,1) > 0 .AND. searchind(i,2) > 0 ) THEN
+             nbind = nbind + 1
+             searchind(nbind,1) = searchind(i,1)
+             searchind(nbind,2) = searchind(i,2)
+          ENDIF
+       ENDDO
+       !
+    ENDDO
+    WRITE(numout,*) ""
+    WRITE(numout,*) "aggregate_2D nbvmax = ",incmax, "max used = ",fopt_max
+    !
+    ! Do some memory management.
+    !
+    DEALLOCATE (laup_rel)
+    DEALLOCATE (loup_rel)
+    DEALLOCATE (lalow_rel)
+    DEALLOCATE (lolow_rel)
+    DEALLOCATE (lat_ful)
+    DEALLOCATE (lon_ful)
+    DEALLOCATE (searchind)
+    !
+    ! Close the progress meter
+    !
+    WRITE(numout,*) '    '
+    !
+  END SUBROUTINE aggregate_2d
+
+  !
+  ! This routing will get for each point of the coarse grid the
+  ! indexes of the finer grid and the area of overlap. 
+  ! This routine is designed for a fine grid which is regular in meters along lat lon axes.
+  !
+  SUBROUTINE aggregate_vec (nbpt, lalo, neighbours, resolution, contfrac, &
+       &                iml, lon_rel, lat_rel, resol_lon, resol_lat, callsign, &
+       &                incmax, indinc, areaoverlap, ok)
+    !
+    ! INPUT
+    ! 
+    INTEGER(i_std), INTENT(in)   :: nbpt                 ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)         ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)   :: neighbours(nbpt,8)   ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)   ! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)       ! Fraction of land in each grid box.
+    INTEGER(i_std), INTENT(in)   :: iml                  ! Size of the finer grid
+    REAL(r_std), INTENT(in)       :: lon_rel(iml)         ! Longitudes for the finer grid
+    REAL(r_std), INTENT(in)       :: lat_rel(iml)         ! Latitudes for the finer grid
+    REAL(r_std), INTENT(in)       :: resol_lon, resol_lat ! Resolution in meters of the fine grid
+    CHARACTER(LEN=*), INTENT(in) :: callsign             ! Allows to specify which variable is beeing treated
+    INTEGER(i_std), INTENT(in)    :: incmax              ! Maximum point of the fine grid we can store.
+    !
+    ! Output
+    !
+    INTEGER(i_std), INTENT(out)  :: indinc(nbpt,incmax)
+    REAL(r_std), INTENT(out)      :: areaoverlap(nbpt,incmax)
+    LOGICAL, OPTIONAL, INTENT(out)      :: ok            ! return code
+    !
+    ! Local Variables
+    !
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: searchind
+    REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
+    REAL(r_std) :: coslat, ax, ay, lonrel, lolowrel, louprel
+    REAL(r_std) :: latrel, lauprel, lalowrel
+    INTEGER(i_std), DIMENSION(nbpt) :: fopt
+    INTEGER(i_std) :: fopt_max
+    INTEGER(i_std) :: ip, ib, i, j, itmp, iprog, nbind
+    REAL(r_std) :: domain_minlon,domain_maxlon,domain_minlat,domain_maxlat
+    INTEGER(i_std) :: ff(1)
+    LOGICAL        :: found
+
+    INTEGER                  :: ALLOC_ERR
+    LOGICAL :: err_fopt
+    err_fopt = .FALSE.
+    !
+    ! Some inital assignmens
+    !
+    areaoverlap(:,:) = moins_un
+    indinc(:,:) = zero
+    !
+    ALLOC_ERR=-1
+    ALLOCATE (searchind(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of searchbind : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    IF (PRESENT(ok)) ok = .TRUE.
+    !
+    !  To speedup calculations we will get the limits of the domain of the 
+    !  coarse grid and select all the points of the fine grid which are potentialy
+    !  in this domain.
+    !
+    !
+    ff = MINLOC(lalo(:,2))
+    coslat = MAX(COS(lalo(ff(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
+    domain_minlon = lalo(ff(1),2) - resolution(ff(1),1)/(2.0*coslat)
+    ff = MAXLOC(lalo(:,2))
+    coslat = MAX(COS(lalo(ff(1),1) * pi/180. ), mincos )*pi/180. * R_Earth
+    domain_maxlon = lalo(ff(1),2) + resolution(ff(1),1)/(2.0*coslat)
+    !
+    coslat = pi/180. * R_Earth
+    domain_minlat = MINVAL(lalo(:,1)) - resolution(ff(1),2)/(2.0*coslat)
+    domain_maxlat = MAXVAL(lalo(:,1)) + resolution(ff(1),2)/(2.0*coslat)
+    !
+    ! we list a first approximation of all point we will need to 
+    ! scan to fill our coarse grid.
+    !
+    IF ( domain_minlon <= -179.5 .AND. domain_maxlon >= 179.5 .AND. &
+      &  domain_minlat <= -89.5  .AND. domain_maxlat >= 89.5 ) THEN
+       ! Here we do the entire globe
+       nbind=0
+       DO ip=1,iml
+          nbind = nbind + 1
+          searchind(nbind) = ip
+       ENDDO
+       !
+    ELSE
+       ! Now we get a limited number of points
+       nbind=0
+       DO ip=1,iml
+          ! Compute the limits of the meshes of the fine grid
+          coslat = MAX(COS(lat_rel(ip) * pi/180. ), mincos )*pi/180. * R_Earth
+          louprel = lon_rel(ip) + resol_lon/(2.0*coslat)
+          lolowrel = lon_rel(ip) - resol_lon/(2.0*coslat)
+          coslat = pi/180. * R_Earth
+          lauprel = lat_rel(ip) + resol_lat/(2.0*coslat)
+          lalowrel = lat_rel(ip) - resol_lat/(2.0*coslat)
+          !
+          IF ( louprel >= domain_minlon .AND. lolowrel <= domain_maxlon .AND.&
+            &  lauprel >= domain_minlat .AND. lalowrel <= domain_maxlat ) THEN
+             nbind = nbind + 1
+             searchind(nbind) = ip
+          ENDIF
+       ENDDO
+    ENDIF
+    !
+    WRITE(numout,*) 'We will work with ', nbind, ' points of the fine grid'
+    !
+    WRITE(numout,*) 'Aggregate_vec : ', callsign
+#ifdef INTERPOL_ADVANCE
+    WRITE(numout,'(2a40)')'0%--------------------------------------', &
+         & '------------------------------------100%'
+#endif
+    !
+    !   Now we take each grid point and find out which values from the forcing we need to average
+    !
+    fopt(:) = zero
+    fopt_max = -1
+    !
+    ! We select here the case which is fastest, i.e. when the smaller loop is inside
+    !
+    IF ( nbpt > nbind ) THEN
+       !
+       loopnbpt : DO ib =1, nbpt
+          !
+          !   Give a progress meter
+          !
+#ifdef INTERPOL_ADVANCE
+          iprog = NINT(REAL(ib,r_std)/REAL(nbpt,r_std)*79.) - NINT(REAL(ib-1,r_std)/REAL(nbpt,r_std)*79.)
+          IF ( iprog .NE. 0 ) THEN
+             WRITE(numout,'(a1,$)') 'x'
+          ENDIF
+#endif
+          !
+          !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+          !  into longitudes and latitudes we do not have the problem of periodicity.
+          !  coslat is a help variable here !
+          !
+          coslat = MAX(COS(lalo(ib,1) * pi/180. ), mincos )*pi/180. * R_Earth
+          !
+          lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat) 
+          lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+          !
+          coslat = pi/180. * R_Earth
+          !
+          lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat) 
+          lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat) 
+          !
+          !  Find the grid boxes from the data that go into the model's boxes
+          !  We still work as if we had a regular grid ! Well it needs to be localy regular so
+          !  so that the longitude at the latitude of the last found point is close to the one 
+          !  of the next point.
+          !
+          DO i=1,nbind
+             !
+             ip = searchind(i)
+             !
+             !  Either the center of the data grid point is in the interval of the model grid or
+             !  the East and West limits of the data grid point are on either sides of the border of
+             !  the data grid.
+             !
+             lonrel = lon_rel(ip)
+             coslat = MAX(COS(lat_rel(ip) * pi/180. ), mincos )*pi/180. * R_Earth
+             louprel = lon_rel(ip) + resol_lon/(2.0*coslat)
+             lolowrel = lon_rel(ip) - resol_lon/(2.0*coslat)
+             !
+             latrel = lat_rel(ip)
+             coslat = pi/180. * R_Earth
+             lauprel = lat_rel(ip) + resol_lat/(2.0*coslat)
+             lalowrel = lat_rel(ip) - resol_lat/(2.0*coslat)
+             !
+             !
+             IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
+                  & lolowrel < lon_low .AND.  louprel > lon_low .OR. &
+                  & lolowrel < lon_up  .AND.  louprel > lon_up ) THEN
+                !
+                ! Now that we have the longitude let us find the latitude
+                !             
+                IF ( latrel > lat_low .AND. latrel < lat_up .OR. &
+                     & lalowrel < lat_low .AND. lauprel > lat_low .OR.&
+                     & lalowrel < lat_up .AND. lauprel > lat_up) THEN
+                   !
+                   fopt(ib) = fopt(ib) + 1
+                   fopt_max = MAX ( fopt(ib), fopt_max )
+                   IF ( fopt(ib) > incmax) THEN
+                      err_fopt=.TRUE.
+                      EXIT loopnbpt
+                   ELSE
+                      !
+                      ! Get the area of the fine grid in the model grid
+                      !
+                      coslat = MAX( COS( lat_rel(ip) * pi/180. ), mincos )
+                      ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
+                      ay = (MIN(lat_up, lauprel)-MAX(lat_low,lalowrel))*pi/180. * R_Earth
+                      !
+                      areaoverlap(ib, fopt(ib)) = ax*ay
+                      indinc(ib, fopt(ib)) = ip
+                      !
+                      ! If this point was 100% within the grid then we can de-select it from our
+                      ! list as it can not be in another mesh of the coarse grid.
+                      !
+                      IF ( louprel < lon_up .AND. lolowrel > lon_low .AND. &
+                           &  lauprel < lat_up .AND. lalowrel > lat_low ) THEN
+                         searchind(i) = 0
+                      ENDIF
+                      !
+                   ENDIF
+                ENDIF       ! IF lat
+             ENDIF          ! IF lon
+          ENDDO
+          !
+          ! De-select the marked points
+          !
+          itmp = nbind
+          nbind = 0
+          DO i=1,itmp
+             IF ( searchind(i) > 0 ) THEN
+                nbind = nbind + 1
+                searchind(nbind) = searchind(i)
+             ENDIF
+          ENDDO
+          !
+       ENDDO loopnbpt
+       IF (err_fopt) THEN
+          WRITE(numout,*) 'Reached value ', fopt(ib),' for fopt on point', ib
+          CALL ipslerr(2,'aggregate_vec (nbpt > nbind)', &
+               'Working on variable :'//callsign, &
+               'Reached incmax value for fopt.',&
+               'Please increase incmax in subroutine calling aggregate')
+          IF (PRESENT(ok)) THEN
+             ok = .FALSE.
+             RETURN
+          ELSE
+             STOP "aggregate_vec"
+          ENDIF
+       ENDIF
+       !
+    ELSE
+       !
+       ib = 1
+       !
+       loopnbind : DO i=1,nbind
+          !
+          !
+          !   Give a progress meter
+          !
+#ifdef INTERPOL_ADVANCE
+          iprog = NINT(REAL(i,r_std)/REAL(nbind,r_std)*79.) - NINT(REAL(i-1,r_std)/REAL(nbind,r_std)*79.)
+          IF ( iprog .NE. 0 ) THEN
+             WRITE(numout,'(a1,$)') 'y'
+          ENDIF
+#endif
+          !
+          ip = searchind(i)
+          !
+          !  Either the center of the data grid point is in the interval of the model grid or
+          !  the East and West limits of the data grid point are on either sides of the border of
+          !  the data grid.
+          !
+          lonrel = lon_rel(ip)
+          coslat = MAX(COS(lat_rel(ip) * pi/180. ), mincos )*pi/180. * R_Earth
+          louprel = lon_rel(ip) + resol_lon/(2.0*coslat)
+          lolowrel = lon_rel(ip) - resol_lon/(2.0*coslat)
+          !
+          latrel = lat_rel(ip)
+          coslat = pi/180. * R_Earth
+          lauprel = lat_rel(ip) + resol_lat/(2.0*coslat)
+          lalowrel = lat_rel(ip) - resol_lat/(2.0*coslat)
+          !
+          !
+          found = .FALSE.
+          j = 1
+          !
+          DO WHILE ( .NOT. found .AND. j <= nbpt ) 
+             ! Just count the number of time we were through
+             j = j+1
+             !
+             !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+             !  into longitudes and latitudes we do not have the problem of periodicity.
+             !  coslat is a help variable here !
+             !
+             coslat = MAX(COS(lalo(ib,1) * pi/180. ), mincos )*pi/180. * R_Earth
+             !
+             lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat) 
+             lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+             !
+             coslat = pi/180. * R_Earth
+             !
+             lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat) 
+             lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat) 
+             !
+             IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
+                  & lolowrel < lon_low .AND.  louprel > lon_low .OR. &
+                  & lolowrel < lon_up  .AND.  louprel > lon_up ) THEN
+                !
+                ! Now that we have the longitude let us find the latitude
+                !             
+                IF ( latrel > lat_low .AND. latrel < lat_up .OR. &
+                     & lalowrel < lat_low .AND. lauprel > lat_low .OR.&
+                     & lalowrel < lat_up .AND. lauprel > lat_up) THEN
+                   !
+                   fopt(ib) = fopt(ib) + 1
+                   fopt_max = MAX ( fopt(ib), fopt_max )
+                   IF ( fopt(ib) > incmax) THEN
+                      err_fopt=.TRUE.
+                      EXIT loopnbind
+                   ELSE
+                      !
+                      ! Get the area of the fine grid in the model grid
+                      !
+                      coslat = MAX( COS( lat_rel(ip) * pi/180. ), mincos )
+                      ax = (MIN(lon_up,louprel)-MAX(lon_low,lolowrel))*pi/180. * R_Earth * coslat
+                      ay = (MIN(lat_up,lauprel)-MAX(lat_low,lalowrel))*pi/180. * R_Earth
+                      !
+                      areaoverlap(ib, fopt(ib)) = ax*ay
+                      indinc(ib, fopt(ib)) = ip
+                      found = .TRUE.
+                      !
+                   ENDIF
+                ENDIF       ! IF lat
+             ENDIF          ! IF lon
+          ENDDO             ! While loop
+       ENDDO loopnbind
+       !
+       IF (err_fopt) THEN
+          WRITE(numout,*) 'Reached value ', fopt(ib),' for fopt on point', ib
+          CALL ipslerr(2,'aggregate_vec (nbpt < nbind)', &
+               'Working on variable :'//callsign, &
+               'Reached incmax value for fopt.',&
+               'Please increase incmax in subroutine calling aggregate')
+          IF (PRESENT(ok)) THEN
+             ok = .FALSE.
+             RETURN
+          ELSE
+             STOP "aggregate_vec"
+          ENDIF
+       ENDIF
+       !
+       IF ( .NOT. found ) THEN
+          ! We need to step on in the coarse grid
+          ib = ib + 1
+          IF ( ib > nbpt ) ib = ib-nbpt
+          !
+       ENDIF
+    ENDIF
+    WRITE(numout,*) 
+    WRITE(numout,*) "aggregate_vec nbvmax = ",incmax, "max used = ",fopt_max
+    !
+    ! Do some memory management.
+    !
+    DEALLOCATE (searchind)
+    !
+    ! Close the progress meter
+    !
+    WRITE(numout,*) '    '
+    !
+  END SUBROUTINE aggregate_vec
+!
+!
+
+  SUBROUTINE aggregate_vec_p(nbpt, lalo, neighbours, resolution, contfrac,          &
+       &                 iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign, &
+       &                 nbvmax, sub_index, sub_area, ok)
+    
+    IMPLICIT NONE
+    
+    INTEGER(i_std), INTENT(in)   :: nbpt                 
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)        
+    INTEGER(i_std), INTENT(in)   :: neighbours(nbpt,8)   
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)   
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)       
+    INTEGER(i_std), INTENT(in)   :: iml                 
+    REAL(r_std), INTENT(in)       :: lon_ful(iml)         
+    REAL(r_std), INTENT(in)       :: lat_ful(iml)         
+    REAL(r_std), INTENT(in)       :: resol_lon, resol_lat 
+    CHARACTER(LEN=*), INTENT(in) :: callsign             
+    INTEGER(i_std), INTENT(in)   :: nbvmax             
+    INTEGER(i_std), INTENT(out)  :: sub_index(nbpt,nbvmax)
+    REAL(r_std), INTENT(out)      :: sub_area(nbpt,nbvmax) 
+    LOGICAL, OPTIONAL, INTENT(out)      :: ok            ! return code
+
+    INTEGER(i_std)  :: sub_index_g(nbp_glo,nbvmax)
+    REAL(r_std)       :: sub_area_g(nbp_glo,nbvmax)
+        
+    IF (is_root_prc) CALL aggregate(nbp_glo, lalo_g, neighbours_g, resolution_g, contfrac_g, &
+   &                                  iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign,   &
+   &                                  nbvmax, sub_index_g, sub_area_g, ok)
+
+    CALL BCAST(ok)
+    CALL scatter(sub_index_g,sub_index)
+    CALL scatter(sub_area_g,sub_area)
+   
+   
+  END SUBROUTINE aggregate_vec_p
+
+  SUBROUTINE aggregate_2d_p(nbpt, lalo, neighbours, resolution, contfrac,          &
+       &                 iml, jml, lon_ful, lat_ful, mask, callsign, &
+       &                 nbvmax, sub_index, sub_area, ok)
+    
+    IMPLICIT NONE
+    
+    INTEGER(i_std), INTENT(in)   :: nbpt                 
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)        
+    INTEGER(i_std), INTENT(in)   :: neighbours(nbpt,8)   
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)   
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)       
+    INTEGER(i_std), INTENT(in)   :: iml,jml                 
+    REAL(r_std), INTENT(in)       :: lon_ful(iml,jml)         
+    REAL(r_std), INTENT(in)       :: lat_ful(iml,jml)         
+    INTEGER(i_std), INTENT(in)   :: mask(iml, jml)
+    CHARACTER(LEN=*), INTENT(in) :: callsign             
+    INTEGER(i_std), INTENT(in)   :: nbvmax             
+    INTEGER(i_std), INTENT(out)  :: sub_index(nbpt,nbvmax,2)
+    REAL(r_std), INTENT(out)      :: sub_area(nbpt,nbvmax) 
+    LOGICAL, OPTIONAL, INTENT(out)      :: ok            ! return code
+
+    INTEGER(i_std)   :: sub_index_g(nbp_glo,nbvmax,2)
+    REAL(r_std)       :: sub_area_g(nbp_glo,nbvmax)
+    
+    IF (is_root_prc) CALL aggregate_2d(nbp_glo, lalo_g, neighbours_g, resolution_g, contfrac_g, &
+   &                                  iml, jml, lon_ful, lat_ful, mask, callsign,   &
+   &                                  nbvmax, sub_index_g, sub_area_g, ok)
+    CALL BCAST(ok)
+    CALL scatter(sub_index_g,sub_index)
+    CALL scatter(sub_area_g,sub_area)
+   
+   
+  END SUBROUTINE aggregate_2d_p
+!
+END MODULE interpol_help
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/solar.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/solar.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_global/solar.f90	(revision 55)
@@ -0,0 +1,202 @@
+!! This module define solar 
+!!
+!! @call sechiba_main
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!!
+!! @author Marie-Alice Foujols, Jan Polcher and Martial Mancip
+!! 
+!!
+MODULE solar
+
+  USE defprec
+  USE constantes
+  USE parallel
+
+  IMPLICIT NONE
+
+
+
+CONTAINS
+  !
+  !f90doc CONTAINS
+  ! 
+  !
+  !
+  !-
+  !=====================================================================
+  SUBROUTINE solarang (julian, julian0, iim, jjm, lon, lat, csang)
+    !---------------------------------------------------------------------
+    !- This subroutine computes the solar angle according to the method
+    !- used by GSWP and developed by J.C. Morill.
+    !- See for further details :
+    !- http://www.atmo.arizona.edu/~morrill/swrad.html
+    !---------------------------------------------------------------------
+    !
+    USE calendar
+    !
+    IMPLICIT NONE
+    !-
+    INTEGER,INTENT(in) :: iim, jjm
+    REAL,INTENT(in)  :: julian
+    REAL,INTENT(in)  :: julian0
+    REAL,DIMENSION(iim,jjm), INTENT(in)  :: lon, lat
+    REAL,DIMENSION(iim,jjm), INTENT(out) :: csang
+    !-
+    REAL :: pi, gamma, dec, decd
+    REAL :: et, gmt, le, ls, lcorr, latime, omega, omegad
+    REAL :: llatd, llat
+    INTEGER :: igmt, ilon, ilat
+    INTEGER,SAVE,ALLOCATABLE :: zone(:), lhour(:)
+    !
+    LOGICAL :: check = .FALSE.
+    !---------------------------------------------------------------------
+    !
+    pi = 4.*ATAN(1.)
+    IF (check) WRITE(numout,*) 'We get the right calendar information'
+    !-
+    !- 1) Day angle gamma
+    !-
+    !   gamma = 2.*pi*MOD(julian,one_year)/one_year
+    gamma = 2.*pi*(julian-julian0)/one_year
+    !-
+    !- 2) Solar declination (assumed constant for a 24 hour period)  page 7
+    !-    in radians
+    !-
+    IF (check) WRITE(numout,*) 'Solar declination'
+    !
+    dec = ( 0.006918-0.399912*COS(gamma)+0.070257*SIN(gamma) &
+         &       -0.006758*COS(2*gamma)+0.000907*SIN(2*gamma)      &
+         &       -0.002697*COS(3*gamma)+0.00148*SIN(3*gamma))
+    decd = dec*(180/pi)
+    !-
+    !- maximum error 0.0006 rad (<3'), leads to error
+    !- of less than 1/2 degree in zenith angle
+    !-
+    IF (check) WRITE(numout,*) 'Equation of time'
+    !- 3)  Equation of time  page 11
+    !-
+    et = ( 0.000075+0.001868*COS(gamma)-0.032077*SIN(gamma)&
+         &      -0.014615*COS(2*gamma)-0.04089*SIN(2*gamma))*229.18
+    !-
+    !- Get the time zones for the current time
+    !-
+    gmt = 24.*(julian-INT(julian))
+    IF (.NOT.ALLOCATED(zone))  ALLOCATE(zone(iim))
+    IF (.NOT.ALLOCATED(lhour)) ALLOCATE(lhour(iim))
+    !-
+    igmt = NINT(gmt)
+    IF (check) WRITE(numout,*) 'Get time zone'
+    CALL time_zone(igmt, iim, jjm, lon, zone, lhour)
+    !-
+    !- Start a loop through the grid
+    !-
+    IF (check) WRITE(numout,*) 'Start a loop through the grid'
+    DO ilon=1,iim
+       !---
+       !--- 4) Local apparent time  page 13
+       !---
+       !--- ls     standard longitude (nearest 15 degree meridian)
+       !--- le     local longtitude
+       !--- lhour  local standard time
+       !--- latime local apparent time
+       !--- lcorr  longitudunal correction (minutes)
+       !---
+       le = lon(ilon,1)
+       ls = ((zone(ilon)-1)*15)-180.
+       lcorr = 4.*(ls-le)*(-1)
+       latime = lhour(ilon)+lcorr/60.+et/60.
+       IF (latime <  0.) latime = latime+24
+       IF (latime > 24.) latime = latime-24
+       !---
+       !--- 5) Hour angle omega  page 15
+       !---
+       !--- hour angle is zero at noon, positive in the morning
+       !--- It ranges from 180 to -180
+       !---
+       !--- omegad is omega in degrees, omega is in radians
+       !---
+       omegad = (latime-12.)*(-15.)
+       omega  = omegad*pi/180.
+       !---
+       DO ilat=1,jjm
+          !-----
+          !----- 6)  Zenith angle  page 15
+          !-----
+          !----- csang cosine of zenith angle (radians)
+          !----- llatd =  local latitude in degrees
+          !----- llat  =  local latitude in radians
+          !-----
+          llatd = lat(1,ilat)
+          llat  = llatd*pi/180.
+          csang(ilon,ilat) = &
+               &  MAX(zero,SIN(dec)*SIN(llat)+COS(dec)*COS(llat)*COS(omega))
+       ENDDO
+    ENDDO
+    !----------------------
+  END SUBROUTINE solarang
+  !-
+  !=====================================================================
+  SUBROUTINE time_zone (gmt, iim, jjm, lon, zone, lhour)
+    !---------------------------------------------------------------------
+    !
+    IMPLICIT NONE
+    !
+    INTEGER :: gmt, iim, jjm, zone(iim), lhour(iim)
+    REAL :: lon(iim,jjm)
+    !-
+    INTEGER :: deg
+    !!??   REAL :: deg
+    INTEGER :: i, ilon, change
+    !---------------------------------------------------------------------
+    DO ilon=1,iim
+       !---
+       !--- Convert longitude index to longtitude in degrees
+       !---
+       deg = lon(ilon,1)
+       !---
+       !--- Determine into which time zone (15 degree interval) the
+       !--- longitude falls.
+       !---
+       DO i=1,25
+          IF (deg < (-187.5+(15*i))) THEN
+             zone(ilon) = i
+             IF (zone(ilon) == 25)   zone(ilon) = 1
+             EXIT
+          ENDIF
+       ENDDO
+       !---
+       !--- Calculate change (in number of hours) from GMT time to
+       !--- local hour.  Change will be negative for zones < 13 and
+       !--- positive for zones > 13.
+       !---
+       !--- There is also a correction for lhour < 0 and lhour > 23
+       !--- to lhour between 0 and 23.
+       !---
+       IF (zone(ilon) < 13) THEN
+          change = zone(ilon)-13
+          lhour(ilon) = gmt+change
+       ENDIF
+       !---
+       IF (zone(ilon) == 13) THEN
+          lhour(ilon) = gmt
+       ENDIF
+       !---
+       IF (zone(ilon) > 13) THEN
+          change = zone(ilon)-13
+          lhour(ilon) = gmt+change
+       ENDIF
+       IF (lhour(ilon) <  0) lhour(ilon) = lhour(ilon)+24
+       IF (lhour(ilon) > 23) lhour(ilon) = lhour(ilon)-24
+       !---
+    ENDDO
+    !-----------------------
+  END SUBROUTINE time_zone
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  
+END MODULE solar
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/AA_make
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/AA_make	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/AA_make	(revision 55)
@@ -0,0 +1,94 @@
+#-
+#- $Id$
+#-
+MODS1 = data_para.f90 \
+        timer.f90 \
+        transfert_para.f90 \
+	ioipsl_para.f90 \
+	tools_para.f90 \
+	parallel.f90
+#\
+# 	orch_write_field.f90 \
+# 	write_field.f90 \
+# 	orch_write_field_p.f90\
+# 	write_field_p.f90
+
+OBJSMODS1 = $(MODS1:.f90=.o)
+#-
+.PRECIOUS : $(MODEL_LIB)
+#-Q- sxnec  .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
+#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
+#-
+all:
+	$(M_K) m_all
+	@echo parallel is OK
+
+m_all: $(MODEL_LIB)($(OBJSMODS1))
+#-Q- intel m_all: WORK_MOD $(MODEL_LIB)($(OBJSMODS1))
+
+$(MODEL_LIB)(%.o) : %.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
+	$(A_C) $(MODEL_LIB) $*.o
+#-Q- sxnec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sxnec 	mv $*.mod $(MODDIR)
+#-Q- sx6nec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx6nec 	mv $*.mod $(MODDIR)
+#-Q- eshpux 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- eshpux 	mv $*.mod $(MODDIR)
+#-Q- sx8mercure 	mv $*.mod $(MODDIR)
+#-Q- sx9mercure 	mv $*.mod $(MODDIR)
+#-Q- sx8brodie 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx8brodie 	mv $*.mod $(MODDIR)
+#-Q- solaris 	mv $*.mod $(MODDIR)
+	$(RM) $*.o
+#-Q- intel
+#-Q- intel WORK_MOD :
+#-Q- intel 	$(RM) work.pcl
+#-Q- intel 	@echo "work.pc" > work.pcl
+#-Q- intel 	@echo "../src_parameters/work.pc" >> work.pcl
+#-Q- intel 	@echo "../src_stomate/work.pc" >> work.pcl
+#-Q- intel 	@echo "../../IOIPSL/src/work.pc" >> work.pcl
+
+config : 
+	$(BINDIR)/Fparser -name PARALLEL $(MODS1)
+	echo 'Configuration of PARALLEL done'
+
+clean:
+	$(RM) $(MODEL_LIB)
+
+$(MODEL_LIB)(mpi_dummy.o):
+
+$(MODEL_LIB)(timer.o):
+
+$(MODEL_LIB)(data_para.o):
+
+$(MODEL_LIB)(orch_write_field.o):
+
+$(MODEL_LIB)(write_field_p.o): \
+  $(MODEL_LIB)(orch_write_field.o)
+
+$(MODEL_LIB)(transfert_para.o): \
+  $(MODEL_LIB)(timer.o) \
+  $(MODEL_LIB)(data_para.o) \
+
+$(MODEL_LIB)(ioipsl_para.o): \
+  $(MODEL_LIB)(transfert_para.o) \
+  $(MODEL_LIB)(data_para.o)
+
+$(MODEL_LIB)(tools_para.o): \
+  $(MODEL_LIB)(timer.o) \
+  $(MODEL_LIB)(data_para.o)
+
+$(MODEL_LIB)(orch_write_field_p.o): \
+  $(MODEL_LIB)(parallel.o)
+
+$(MODEL_LIB)(write_field_p.o): \
+  $(MODEL_LIB)(parallel.o) \
+  $(MODEL_LIB)(orch_write_field_p.o)
+
+$(MODEL_LIB)(parallel.o): \
+  $(MODEL_LIB)(data_para.o) \
+  $(MODEL_LIB)(transfert_para.o) \
+  $(MODEL_LIB)(ioipsl_para.o) 
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/AA_make.ldef
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/AA_make.ldef	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/AA_make.ldef	(revision 55)
@@ -0,0 +1,19 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a PARALLEL
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+ORDIR  = ..
+#---------------------------------------------------------------------
+MODEL_LIB = $(LIBDIR)/libparallel.a
+SXMODEL_LIB = $(MODEL_LIB)
+#-Q- sxnec  SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxparallel.a
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/data_para.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/data_para.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/data_para.f90	(revision 55)
@@ -0,0 +1,527 @@
+! Definition and allocation of parallel datas.
+! Initialization of parallel or sequentiel IOs.
+! Definition of Load Balancing functions.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/data_para.f90,v 1.7 2010/04/06 14:31:57 ssipsl Exp $
+!-
+
+MODULE data_para
+
+!-
+  USE defprec
+  USE ioipsl
+!-
+#include "src_parallel.h"
+!-
+!-
+! Unit for output messages
+  INTEGER(i_std), SAVE :: numout = 6
+
+  INTEGER, SAVE :: mpi_size                                           !! Number of parallel processes
+  INTEGER, SAVE :: mpi_rank                                           !! my rank num
+  INTEGER, SAVE :: root_prc                                           !! rank of root proc
+  LOGICAL, SAVE :: is_root_prc                                        !! Only root proc is true
+  INTEGER, SAVE :: nbp_loc                                            !! number of local continental points
+  INTEGER, SAVE :: nbp_glo                                            !! number of global continental points
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: nbp_para_end
+  
+  INTEGER,SAVE :: iim_g, jjm_g                                  !! Dimension of global fields
+  ! i x j 2D points (not land points) index
+  INTEGER,SAVE,allocatable,dimension(:) :: ij_para_nb           ! Number of 2D points for each mpi_rank block
+  INTEGER,SAVE,allocatable,dimension(:) :: ij_para_begin        ! First 2D point for each mpi_rank block
+  INTEGER,SAVE,allocatable,dimension(:) :: ij_para_end          ! Last 2D point for each mpi_rank block
+  ! i 2D index 
+  INTEGER,SAVE,allocatable,dimension(:) :: ii_para_begin        ! First i index of 2D point for each mpi_rank block
+  INTEGER,SAVE,allocatable,dimension(:) :: ii_para_end          ! Last i index of 2D point for each mpi_rank block
+  ! j 2D index
+  INTEGER,SAVE,allocatable,dimension(:) :: jj_para_nb           ! Number of complete j lines for each mpi_rank block
+  INTEGER,SAVE,allocatable,dimension(:) :: jj_para_begin        ! First j index of 2D point for each mpi_rank block
+  INTEGER,SAVE,allocatable,dimension(:) :: jj_para_end          ! Last j index of 2D point for each mpi_rank block
+  
+  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
+ 
+  
+  !! Global array used by stomate and sechiba
+  !-
+  !! index of land points on the 2D map
+  INTEGER(i_std),ALLOCATABLE,DIMENSION(:),SAVE   :: index_g
+  !-
+  !! indices of the 4 neighbours of each grid point (1=N, 2=E, 3=S, 4=W)
+  INTEGER(i_std),ALLOCATABLE,DIMENSION(:,:),SAVE :: neighbours_g
+  !-
+  !! resolution at each grid point in m (1=E-W, 2=N-S)
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:),SAVE    :: resolution_g 
+  REAL(r_std),ALLOCATABLE,DIMENSION(:),SAVE    :: area_g 
+  !-
+  !! Geographical coordinates
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:),SAVE    :: lalo_g
+  ! Global grid, for all process
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:), SAVE     :: lon_g, lat_g, zlev_g
+  !-
+  !! Fraction of continents
+  REAL(r_std),ALLOCATABLE,DIMENSION(:),SAVE      :: contfrac_g
+ 
+  INTEGER, SAVE :: MPI_COMM_ORCH
+  INTEGER, SAVE :: MPI_REAL_ORCH
+  INTEGER, SAVE :: MPI_INT_ORCH
+  LOGICAL, SAVE :: cpl_lmdz
+  
+  INTEGER, SAVE :: orch_domain_id
+  
+CONTAINS
+  
+  SUBROUTINE init_para(cpl_lmdz_x, communicator)
+
+    IMPLICIT NONE
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    LOGICAL :: cpl_lmdz_x
+    INTEGER,OPTIONAL :: communicator
+    INTEGER :: ierr
+    CHARACTER(LEN=20) :: filename
+    INTEGER :: i, div
+    CHARACTER(LEN=4) :: num
+    LOGICAL, PARAMETER :: check = .FALSE.
+
+    cpl_lmdz=cpl_lmdz_x
+      
+#ifdef CPP_PARA
+    ! Orchidee communicator :
+    IF (.NOT. cpl_lmdz) THEN
+       CALL MPI_INIT(ierr)
+       IF (ierr /= 0) THEN
+          WRITE(*,*) 'INIT_PARA : MPI_INIT failed with ',ierr
+          STOP "INIT_PARA"          
+       ENDIF
+       MPI_COMM_ORCH=MPI_COMM_WORLD
+    ELSE
+       MPI_COMM_ORCH=communicator
+    ENDIF
+	  
+    
+    ! Int and real precision
+    IF (MPI_VERSION == 1) THEN
+       ! Version MPI 1.x
+       IF (i_std==i_4) THEN
+          MPI_INT_ORCH=MPI_INTEGER
+       ELSEIF (i_std==i_8) THEN
+          MPI_INT_ORCH=MPI_INTEGER
+       ELSE
+          MPI_INT_ORCH=MPI_INTEGER
+       ENDIF
+       
+       IF (r_std==r_4) THEN
+          MPI_REAL_ORCH=MPI_REAL
+       ELSEIF (r_std==r_8) THEN
+          MPI_REAL_ORCH=MPI_DOUBLE_PRECISION
+       ELSE
+          MPI_REAL_ORCH=MPI_REAL
+       ENDIF
+    ELSE
+       ! Others MPI
+       IF (i_std==i_4) THEN
+          MPI_INT_ORCH=MPI_INTEGER4
+       ELSEIF (i_std==i_8) THEN
+          MPI_INT_ORCH=MPI_INTEGER8
+       ELSE
+          MPI_INT_ORCH=MPI_INTEGER
+       ENDIF
+         
+       IF (r_std==r_4) THEN
+          MPI_REAL_ORCH=MPI_REAL4
+       ELSEIF (r_std==r_8) THEN
+          MPI_REAL_ORCH=MPI_REAL8
+       ELSE
+          MPI_REAL_ORCH=MPI_REAL
+       ENDIF
+    ENDIF
+      
+    CALL MPI_COMM_SIZE(MPI_COMM_ORCH,mpi_size,ierr)
+    IF (ierr /= 0) THEN
+       WRITE(*,*) 'INIT_PARA : MPI_COMM_SIZE failed with ',ierr
+       STOP "INIT_PARA"
+    ENDIF
+    CALL MPI_COMM_RANK(MPI_COMM_ORCH,mpi_rank,ierr)
+    IF (ierr /= 0) THEN
+       WRITE(*,*) 'INIT_PARA : MPI_COMM_RANK failed with ',ierr
+       STOP "INIT_PARA"
+    ENDIF
+      
+#else
+    mpi_rank=0
+    mpi_size=1    
+#endif
+    root_prc=0
+      
+    IF (mpi_rank==0) THEN
+       is_root_prc=.TRUE.
+    ELSE
+       is_root_prc=.FALSE.
+    ENDIF
+
+    ! Open mpi_rank outputs or select stdout 
+    IF (mpi_size > 1) THEN
+       write(num,'(I4.4)') mpi_rank
+       
+       numout = 100
+       
+       filename =  'out_orchidee_'//num
+       
+       OPEN(UNIT=numout,FILE=TRIM(filename),ACTION='write',STATUS='unknown',FORM='formatted',IOSTAT=ierr) 
+       IF (ierr /= 0) THEN
+#ifdef CPP_PARA
+          CALL MPI_FINALIZE(ierr)
+#endif
+          WRITE(*,*) "Erreur can't open file ", filename
+          STOP "INIT_PARA"
+       ENDIF
+    ELSE
+       numout = 6
+    ENDIF
+
+    IF (check) THEN
+#ifdef CPP_PARA
+       WRITE(numout,*) 'version MPI ', MPI_VERSION, MPI_SUBVERSION
+       WRITE(numout,*) 'INTEGERS ',MPI_INTEGER4,MPI_INTEGER8,MPI_INTEGER,MPI_INT_ORCH
+       WRITE(numout,*) 'REALS ',MPI_REAL4,MPI_REAL8,MPI_REAL,MPI_REAL_ORCH
+#endif
+       WRITE(numout,*) 'RANK ',mpi_rank,' SIZE ',mpi_size
+       WRITE(numout,*) "Am I root process ?",is_root_prc
+       WRITE(numout,*) "Init_para : For process number ",mpi_rank, "output file = ",filename
+    ENDIF
+      
+  END SUBROUTINE init_para
+ 
+  SUBROUTINE init_data_para(iim,jjm,nbpoints,index_x)
+
+    IMPLICIT NONE
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER,INTENT(IN) :: iim
+    INTEGER,INTENT(IN) :: jjm
+    INTEGER,INTENT(IN) :: nbpoints
+    INTEGER,DIMENSION(:),INTENT(IN) :: index_x
+
+    INTEGER,ALLOCATABLE,DIMENSION(:) :: index_l
+    INTEGER,ALLOCATABLE,DIMENSION(:) :: displs
+#ifdef CPP_PARA
+    INTEGER :: ierr
+#endif  
+    INTEGER :: i
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+
+    IF (check) WRITE(numout,*) 'INIT_DATA_PARA',iim,jjm,nbpoints,index_x
+    ALLOCATE(nbp_para_nb(0:mpi_size-1))
+    ALLOCATE(nbp_para_begin(0:mpi_size-1))
+    ALLOCATE(nbp_para_end(0:mpi_size-1))
+    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(ii_para_begin(0:mpi_size-1))
+    ALLOCATE(ii_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))
+
+    IF (cpl_lmdz) THEN
+#ifdef CPP_PARA
+       CALL MPI_GATHER(nbpoints,1,MPI_INT_ORCH,nbp_para_nb,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+#else
+       nbp_para_nb(0)=nbpoints
+#endif
+
+       IF (is_root_prc) THEN
+          nbp_glo=sum(nbp_para_nb)
+          ALLOCATE(displs(0:mpi_size-1))
+	  ALLOCATE(index_l(nbp_glo))
+          displs(0)=0
+          DO i=1,mpi_size-1
+             displs(i)=displs(i-1)+nbp_para_nb(i-1)
+          ENDDO
+       ENDIF
+#ifdef CPP_PARA
+       CALL MPI_BCAST(nbp_glo,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+       CALL MPI_GATHERV(index_x,nbpoints,MPI_INT_ORCH,index_l,nbp_para_nb,displs,&
+            MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)  
+#else
+       ! if not parallized, nb_glo=nbpoints=nbp_para_nb
+       IF (is_root_prc) index_l(:)=index_x(1:nbp_glo)
+#endif
+    ELSE
+       IF (is_root_prc) THEN
+          nbp_glo=nbpoints
+          ALLOCATE(index_l(nbp_glo))
+          index_l(:)=index_x(1:nbp_glo)
+          CALL Read_Load_Balance(nbpoints,nbp_para_nb)
+       ENDIF
+    ENDIF
+
+    IF (is_root_prc) THEN
+
+       IF (check) WRITE(numout,*) '==== DISTRIB ====',nbpoints,nbp_para_nb
+
+       nbp_para_begin(0)=1
+       nbp_para_end(0)=nbp_para_nb(0)
+
+       DO i=1,mpi_size-1
+          nbp_para_begin(i)=nbp_para_end(i-1)+1
+          nbp_para_end(i)=nbp_para_begin(i)+nbp_para_nb(i)-1
+       ENDDO
+
+       nbp_loc=nbp_para_nb(mpi_rank)
+
+       iim_g=iim
+       jjm_g=jjm
+
+
+       ij_para_begin(0)=1
+       ij_para_end(0)=index_l(nbp_para_end(0))
+       ij_para_nb(0)=ij_para_end(0)-ij_para_begin(0)+1
+
+       DO i=1,mpi_size-1
+          ij_para_begin(i)=ij_para_end(i-1)+1
+          ij_para_end(i)=index_l(nbp_para_end(i))
+	  ij_para_nb(i)=ij_para_end(i)-ij_para_begin(i)+1
+       ENDDO
+
+       ij_para_end(mpi_size-1)=iim*jjm
+       ij_para_nb(mpi_size-1)=ij_para_end(mpi_size-1)-ij_para_begin(mpi_size-1)+1
+
+
+       DO i=0,mpi_size-1
+          jj_para_begin(i)=(ij_para_begin(i)-1)/iim + 1
+	  jj_para_end(i)=(ij_para_end(i)-1)/iim + 1
+          jj_para_nb(i)=jj_para_end(i)-jj_para_begin(i)+1
+
+	  ii_para_begin(i)=MOD(ij_para_begin(i)-1,iim)+1
+	  ii_para_end(i)=MOD(ij_para_end(i)-1,iim)+1
+       ENDDO
+
+       IF (check) THEN
+          WRITE(numout,*) '==== DECOUP ===='
+          WRITE(numout,*) 'nbp_para_begin=',nbp_para_begin
+          WRITE(numout,*) 'nbp_para_end  =',nbp_para_end
+          WRITE(numout,*) 'nbp_loc=',nbp_loc
+
+          WRITE(numout,*) 'ij_para_begin=',ij_para_begin
+          WRITE(numout,*) 'ij_para_end=',ij_para_end
+          WRITE(numout,*) 'ij_para_nb=',ij_para_nb
+          WRITE(numout,*) 'jj_para_begin=',jj_para_begin
+          WRITE(numout,*) 'jj_para_end=',jj_para_end
+          WRITE(numout,*) 'jj_para_nb=',jj_para_nb	
+          WRITE(numout,*) 'ii_para_begin=',ii_para_begin
+          WRITE(numout,*) 'ii_para_end=',ii_para_end
+       ENDIF
+
+       !
+       !- Root need the global variables
+       !-
+       ALLOCATE(resolution_g(nbp_glo,2),area_g(nbp_glo),lalo_g(nbp_glo,2))
+       ALLOCATE(neighbours_g(nbp_glo,8),contfrac_g(nbp_glo),index_g(nbp_glo))
+       ALLOCATE(lon_g(iim_g, jjm_g), lat_g(iim_g, jjm_g), zlev_g(iim_g, jjm_g))
+
+       index_g(:)=index_l(1:nbp_glo)
+    ENDIF
+
+#ifdef CPP_PARA
+    IF (is_root_prc) WRITE(numout,*) 'nbp_para_nb =',nbp_para_nb
+    CALL MPI_BCAST(nbp_para_nb,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(nbp_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(nbp_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(jj_para_nb,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(jj_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(jj_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(ii_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(ii_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(ij_para_nb,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(ij_para_begin,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(ij_para_end,mpi_size,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(iim_g,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(jjm_g,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    CALL MPI_BCAST(nbp_glo,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+#endif
+
+    nbp_loc=nbp_para_nb(mpi_rank)
+
+    ij_nb=ij_para_nb(mpi_rank)
+    ij_begin=ij_para_begin(mpi_rank)
+    ij_end=ij_para_end(mpi_rank)
+
+    jj_nb=jj_para_nb(mpi_rank)
+    jj_begin=jj_para_begin(mpi_rank)
+    jj_end=jj_para_end(mpi_rank)
+
+    ii_begin=ii_para_begin(mpi_rank)
+    ii_end=ii_para_end(mpi_rank)
+
+    IF (check) &
+         WRITE(numout,*) 'Init_io_para'
+    CALL Init_io_para
+
+    IF (is_root_prc ) THEN 
+       DEALLOCATE(index_l)
+       IF ( cpl_lmdz) THEN
+          DEALLOCATE(displs)
+       ENDIF
+    ENDIF
+
+    IF (check) &
+         WRITE(numout,*)  'DATA PARA',nbp_loc,nbp_glo,jj_begin,jj_end,ii_begin,ii_end       
+  END SUBROUTINE init_data_para
+  
+
+  SUBROUTINE Init_io_para
+    USE ioipsl
+    IMPLICIT NONE
+    
+    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 
+
+    ddid=(/ 1,2 /)
+    dsg=(/ iim_g, jjm_g /)
+    dsl=(/ iim_g, jj_nb /)
+    dpf=(/ 1,jj_begin /)
+    dpl=(/ iim_g, jj_end /)
+    dhs=(/ ii_begin-1,0 /)
+    if (mpi_rank==mpi_size-1) then
+      dhe=(/0,0/)
+    else
+      dhe=(/ iim_g-ii_end,0 /)  
+    endif
+    
+    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+                      'APPLE',orch_domain_id)
+  END SUBROUTINE Init_io_para
+  
+  SUBROUTINE Read_Load_balance(NbPoints,Nbpoints_loc)
+
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: NbPoints
+    INTEGER,INTENT(OUT) :: Nbpoints_loc(0:mpi_size-1)
+#ifdef CPP_PARA  
+    INTEGER :: unit_number=10
+    CHARACTER(len=255)  :: filename='Load_balance_orchidee.dat'
+    INTEGER :: j
+#endif
+    INTEGER :: i,s,ierr
+    
+    Nbpoints_loc(:) = 0
+
+#ifdef CPP_PARA
+    OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr) 
+#else
+    ierr=1
+#endif   
+    s=0
+
+#ifdef CPP_PARA  
+    IF (ierr==0) THEN
+       i=0
+       !- Reading for any balancing file (even with a bad structure)
+       DO WHILE (i < mpi_size .AND. ierr == 0) 
+          READ (unit_number,*,IOSTAT=ierr) j,Nbpoints_loc(i)
+          s=s+Nbpoints_loc(i)
+          i=i+1
+       ENDDO
+       CLOSE(unit_number)
+    ENDIF
+#endif   
+    
+    !- Correction of bad balancing file (or an empty file) => same nb of points for each procs
+    IF (ierr/=0 .OR. s/=Nbpoints) THEN
+       DO i=0,mpi_size-1
+          Nbpoints_loc(i)=Nbpoints/mpi_size
+          IF (MOD(Nbpoints,mpi_size) > i) Nbpoints_loc(i)=Nbpoints_loc(i)+1
+       ENDDO
+    ENDIF
+    
+  END SUBROUTINE Read_Load_balance
+  
+  SUBROUTINE Write_Load_balance(times)
+    IMPLICIT NONE
+    REAL(r_std),INTENT(IN) :: times
+  
+#ifdef CPP_PARA  
+    CHARACTER(len=255)  :: filename='Load_balance_orchidee.dat'
+    INTEGER :: unit_number=10
+    INTEGER :: i,ierr
+    REAL :: All_Times(0:mpi_size-1)
+    REAL :: average
+    REAL :: efficiency
+    INTEGER :: dp,S
+    INTEGER :: New_nbpoints(0:mpi_size-1)
+#endif
+    
+    WRITE(numout,*) 'time',times
+#ifndef CPP_PARA
+    RETURN
+#else
+
+    CALL MPI_GATHER(times,1,MPI_REAL_ORCH,All_times,1,MPI_REAL_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    IF (is_root_prc) WRITE(numout,*) 'ALL_times',All_times
+
+    IF (is_root_prc) THEN
+     
+       OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
+       
+       average=sum(All_times(:))/mpi_size
+       DO i=0,mpi_size-1
+          efficiency=All_times(i)/Nbp_para_nb(i)
+          New_nbpoints(i)=Nbp_para_nb(i)-(All_times(i)-average)/efficiency
+       ENDDO
+       
+       S=sum(new_nbpoints(:))
+       dp=nbp_glo-S
+       
+       IF ( dp > 0 ) THEN
+          DO WHILE ( dp > 0 )
+             New_nbpoints(MOD(dp,mpi_size))=New_nbpoints(MOD(dp,mpi_size))+1
+             dp=dp-1
+          ENDDO
+       ELSE
+          dp=-dp
+          DO WHILE ( dp > 0 )
+             New_nbpoints(MOD(dp,mpi_size))=New_nbpoints(MOD(dp,mpi_size))-1
+             dp=dp-1
+          ENDDO
+       ENDIF
+       
+       ! If this algorithm diverge, we use previous repartition.
+       IF ( ANY(New_nbpoints(:) .LE. 0) ) THEN
+          New_nbpoints(:)=Nbp_para_nb(:)
+       ENDIF
+       
+       DO i=0,mpi_size-1
+          WRITE(Unit_number,*) i,New_nbpoints(i)
+       ENDDO
+       CLOSE(Unit_number)
+    ENDIF
+#endif
+ 
+  END SUBROUTINE Write_Load_Balance
+  
+  
+  
+END MODULE data_para
+
+#include "mpi_dummy.h"
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/ioipsl_para.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/ioipsl_para.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/ioipsl_para.f90	(revision 55)
@@ -0,0 +1,382 @@
+! Overlap of IOIPSL functions for specific parallel use in ORCHIDEE.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/ioipsl_para.f90,v 1.4 2008/01/08 11:52:35 ssipsl Exp $
+!-
+
+MODULE ioipsl_para
+  USE ioipsl
+  USE data_para
+  USE transfert_para
+!-
+  IMPLICIT NONE
+!-
+#include "src_parallel.h"
+!-
+  INTERFACE getin_p
+    MODULE PROCEDURE getin_p_c,                      &
+         getin_p_i,getin_p_i1,getin_p_i2,&
+         getin_p_r,getin_p_r1,getin_p_r2,&
+         getin_p_l,getin_p_l1,getin_p_l2
+  END INTERFACE
+!-
+  INTERFACE restput_p
+     MODULE PROCEDURE &
+          restput_p_r3d, restput_p_r2d, restput_p_r1d, &
+          restput_p_opp_r2d, restput_p_opp_r1d
+  END INTERFACE
+!-
+  INTERFACE restget_p
+     MODULE PROCEDURE &
+          restget_p_r3d, restget_p_r2d, restget_p_r1d, &
+          restget_p_opp_r2d, restget_p_opp_r1d
+  END INTERFACE
+
+CONTAINS
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!   Definition des getin -> bcast      !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaines de caracteres -- !!
+  
+  SUBROUTINE getin_p_c(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    CHARACTER(LEN=*),INTENT(INOUT) :: VarOut    
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_c  
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE getin_p_i(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    INTEGER,INTENT(INOUT) :: VarOut    
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_i
+
+  SUBROUTINE getin_p_i1(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    INTEGER,INTENT(INOUT) :: VarOut(:)
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_i1
+
+  SUBROUTINE getin_p_i2(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    INTEGER,INTENT(INOUT) :: VarOut(:,:)
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_i2
+
+!! -- Les flottants -- !!
+  
+  SUBROUTINE getin_p_r(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    REAL,INTENT(INOUT) :: VarOut
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_r
+
+  SUBROUTINE getin_p_r1(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    REAL,INTENT(INOUT) :: VarOut(:)
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_r1
+
+  SUBROUTINE getin_p_r2(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    REAL,INTENT(INOUT) :: VarOut(:,:)
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_r2
+
+!! -- Les Booleens -- !!
+  
+  SUBROUTINE getin_p_l(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    LOGICAL,INTENT(INOUT) :: VarOut
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_l
+
+  SUBROUTINE getin_p_l1(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    LOGICAL,INTENT(INOUT) :: VarOut(:)
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_l1
+
+  SUBROUTINE getin_p_l2(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    LOGICAL,INTENT(INOUT) :: VarOut(:,:)
+
+    IF (is_root_prc) CALL getin(VarIn,VarOut)
+    CALL bcast(VarOut)
+  END SUBROUTINE getin_p_l2
+!-
+!-----------------------------
+!-----------------------------
+!-----------------------------
+!-
+  SUBROUTINE restget_p_opp_r1d &
+  (fid, vname_q, iim, jjm, llm, itau, def_beha, &
+   var, MY_OPERATOR, nbindex, ijndex)
+! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    LOGICAL def_beha
+    REAL :: var(:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim*jjm*llm) )
+       CALL restget &
+            (fid, vname_q, iim, jjm, llm, itau, def_beha, &
+            temp_g, MY_OPERATOR, nbindex, ijndex)
+    ENDIF
+    CALL scatter(temp_g,var)
+    IF (is_root_prc) DEALLOCATE(temp_g)
+  END SUBROUTINE restget_p_opp_r1d
+!-
+!===
+!-
+  SUBROUTINE restget_p_opp_r2d &
+  (fid, vname_q, iim, jjm, llm, itau, def_beha, &
+   var, MY_OPERATOR, nbindex, ijndex)
+    IMPLICIT NONE
+    !-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    LOGICAL def_beha
+    REAL :: var(:,:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim,jjm) )
+       CALL restget &
+            (fid, vname_q, iim, jjm, llm, itau, def_beha, &
+            temp_g, MY_OPERATOR, nbindex, ijndex)
+    ENDIF
+    CALL scatter(temp_g,var)
+    IF (is_root_prc) DEALLOCATE(temp_g)
+  END SUBROUTINE restget_p_opp_r2d
+!-
+!===
+!-
+  SUBROUTINE restget_p_r1d &
+  (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
+! DO NOT USE THIS FUNCTION WITH NON GRID VARIABLE !
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    LOGICAL :: def_beha
+    REAL :: var(:)
+    !-------------------------
+    REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim*jjm*llm) )
+       CALL restget &
+            (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
+    ENDIF
+    CALL scatter(temp_g,var)
+    IF (is_root_prc) DEALLOCATE(temp_g)
+  END SUBROUTINE restget_p_r1d
+!-
+!===
+!-
+  SUBROUTINE restget_p_r2d &
+  (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    LOGICAL :: def_beha
+    REAL :: var(:,:)
+    !-------------------------
+    REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim,jjm) )
+       CALL restget &
+            (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
+    ENDIF
+    CALL scatter(temp_g,var)
+    IF (is_root_prc) DEALLOCATE(temp_g)
+  END SUBROUTINE restget_p_r2d
+!-
+!===
+!-
+  SUBROUTINE restget_p_r3d &
+  (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    LOGICAL def_beha
+    REAL :: var(:,:,:)
+    !-------------------------
+    REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
+
+    IF (is_root_prc) THEN 
+       ALLOCATE( temp_g(iim,jjm,llm) )
+       CALL restget &
+            (fid,vname_q,iim,jjm,llm,itau,def_beha,temp_g)
+    ENDIF
+    CALL scatter(temp_g,var)
+    IF (is_root_prc) DEALLOCATE(temp_g)
+  END SUBROUTINE restget_p_r3d
+!-
+!-----------------------------
+!-----------------------------
+!-
+  SUBROUTINE restput_p_opp_r1d &
+  (fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    REAL :: var(:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) ALLOCATE( temp_g(iim*jjm*llm) )
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput &
+            (fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
+
+       DEALLOCATE( temp_g )
+    ENDIF
+          
+  END SUBROUTINE restput_p_opp_r1d
+!-
+!===
+!-
+  SUBROUTINE restput_p_opp_r2d &
+  (fid, vname_q, iim, jjm, llm, itau, var, MY_OPERATOR, nbindex, ijndex)
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    REAL :: var(:,:)
+    CHARACTER(LEN=*) :: MY_OPERATOR
+    INTEGER :: nbindex, ijndex(nbindex)
+    !-----------------------------
+    REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) ALLOCATE( temp_g(iim,jjm) )
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput &
+            (fid, vname_q, iim, jjm, llm, itau, temp_g, MY_OPERATOR, nbindex, ijndex)
+       DEALLOCATE( temp_g )
+    ENDIF
+          
+  END SUBROUTINE restput_p_opp_r2d
+!-
+!===
+!-
+  SUBROUTINE restput_p_r1d (fid,vname_q,iim,jjm,llm,itau,var)
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    REAL :: var(:)
+    !-----------------------------
+    REAL, ALLOCATABLE, DIMENSION(:) :: temp_g
+
+    IF (is_root_prc) ALLOCATE( temp_g(iim*jjm*llm) )
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
+       DEALLOCATE( temp_g )
+    ENDIF
+          
+  END SUBROUTINE restput_p_r1d
+!-
+!===
+!-
+  SUBROUTINE restput_p_r2d (fid,vname_q,iim,jjm,llm,itau,var)
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    REAL :: var(:,:)
+    !-------------------------
+    REAL, ALLOCATABLE, DIMENSION(:,:) :: temp_g
+
+    IF (is_root_prc) ALLOCATE( temp_g(iim,jjm) )
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
+       DEALLOCATE( temp_g )
+    ENDIF
+          
+  END SUBROUTINE restput_p_r2d
+!-
+!===
+!-
+  SUBROUTINE restput_p_r3d (fid,vname_q,iim,jjm,llm,itau,var)
+    IMPLICIT NONE
+!-
+    INTEGER :: fid
+    CHARACTER(LEN=*) :: vname_q
+    INTEGER :: iim, jjm, llm, itau
+    REAL :: var(:,:,:)
+    !-------------------------
+    REAL, ALLOCATABLE, DIMENSION(:,:,:) :: temp_g
+
+    IF (is_root_prc) ALLOCATE( temp_g(iim,jjm,llm) )
+    CALL gather(var,temp_g)
+    IF (is_root_prc) THEN
+       CALL restput (fid,vname_q,iim,jjm,llm,itau,temp_g)
+       DEALLOCATE( temp_g )
+    ENDIF
+          
+  END SUBROUTINE restput_p_r3d
+
+END MODULE ioipsl_para
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/mpi_dummy.h
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/mpi_dummy.h	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/mpi_dummy.h	(revision 55)
@@ -0,0 +1,60 @@
+! Overlapp of MPI functions not present in some MPI implementations.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/mpi_dummy.h,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
+!-
+#ifdef MPI_SECOND__
+
+SUBROUTINE MPI_NULL_COPY_FN
+END SUBROUTINE MPI_NULL_COPY_FN
+
+SUBROUTINE MPI_NULL_DELETE_FN
+END SUBROUTINE MPI_NULL_DELETE_FN
+
+SUBROUTINE MPI_COMM_NULL_COPY_FN
+END SUBROUTINE MPI_COMM_NULL_COPY_FN
+
+SUBROUTINE MPI_COMM_NULL_DELETE_FN
+END SUBROUTINE MPI_COMM_NULL_DELETE_FN
+
+SUBROUTINE MPI_TYPE_NULL_COPY_FN
+END SUBROUTINE MPI_TYPE_NULL_COPY_FN
+
+SUBROUTINE MPI_TYPE_NULL_DELETE_FN
+END SUBROUTINE MPI_TYPE_NULL_DELETE_FN
+
+SUBROUTINE MPI_WIN_NULL_COPY_FN
+END SUBROUTINE MPI_WIN_NULL_COPY_FN
+
+SUBROUTINE MPI_WIN_NULL_DELETE_FN
+END SUBROUTINE MPI_WIN_NULL_DELETE_FN
+
+SUBROUTINE MPI_DUP_FN
+END SUBROUTINE MPI_DUP_FN
+
+SUBROUTINE MPI_COMM_DUP_FN
+END SUBROUTINE MPI_COMM_DUP_FN
+
+SUBROUTINE MPI_TYPE_DUP_FN
+END SUBROUTINE MPI_TYPE_DUP_FN
+
+SUBROUTINE MPI_WIN_DUP_FN
+END SUBROUTINE MPI_WIN_DUP_FN
+
+FUNCTION MPI_WTIME () RESULT (R)
+  DOUBLE PRECISION R
+END FUNCTION MPI_WTIME
+
+FUNCTION MPI_WTICK () RESULT (R)
+  DOUBLE PRECISION :: R
+END FUNCTION MPI_WTICK
+
+FUNCTION PMPI_WTIME () RESULT (R)
+  DOUBLE PRECISION R
+END FUNCTION PMPI_WTIME
+
+FUNCTION PMPI_WTICK () RESULT (R)
+  DOUBLE PRECISION R
+END FUNCTION PMPI_WTICK
+
+#endif
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/orch_write_field.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/orch_write_field.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/orch_write_field.f90	(revision 55)
@@ -0,0 +1,282 @@
+! Yann Meurdesoif functions for sequentiel tests.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/orch_write_field.f90,v 1.4 2009/09/17 12:32:29 ssipsl Exp $
+!-
+
+module orch_Write_Field
+  
+  USE data_para
+
+  IMPLICIT NONE
+
+!-
+#include "src_parallel.h"
+!-
+  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,dimension(:), allocatable :: Index_Write_Field
+  integer,save :: iim
+  integer,save :: jjm
+  integer,save :: NbPoint
+  real, parameter :: undef_var=0.
+  
+  integer,save :: NbField = 0
+  
+  interface WriteField
+    module procedure WriteField_4d,WriteField_3d,WriteField_2d,WriteField_1d
+  end interface WriteField
+ 
+  interface WriteFieldI
+    module procedure WriteFieldI_3d,WriteFieldI_2d,WriteFieldI_1d
+  end interface WriteFieldI
+
+  private :: iim,jjm,NbPoint 
+  contains
+  
+    subroutine Init_WriteField(iim0,jjm0,NbPoint0,Index0)
+    implicit none
+      integer,intent(in) :: iim0
+      integer,intent(in) :: jjm0
+      integer,intent(in) :: NbPoint0
+      integer,intent(in) :: Index0(NbPoint0)
+    
+      iim=iim0
+      jjm=jjm0
+      Nbpoint=Nbpoint0
+      ALLOCATE(Index_Write_Field(NbPoint))
+      Index_Write_Field(:)=Index0(:)
+    end subroutine Init_WriteField
+    
+    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 WriteFieldI_3d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:,:) :: Field 
+      integer, dimension(3) :: Dim
+      integer,dimension(4) :: Dim_tmp
+      integer :: i
+      
+      real, allocatable, dimension(:,:,:) :: Field_tmp 
+      
+      Dim=shape(Field)
+      allocate(Field_tmp(iim*jjm,Dim(2),dim(3)))
+      field_tmp(:,:,:)=undef_var
+      
+      do i=1,NbPoint
+        field_tmp(Index_Write_Field(i),:,:)=Field(i,:,:)
+      enddo
+      
+      Dim_tmp(1)=iim
+      Dim_tmp(2)=jjm
+      Dim_tmp(3)=dim(2)
+      Dim_tmp(4)=dim(3)
+      call WriteField_gen(name,Field_tmp,4,Dim_tmp)  
+  
+      deallocate(Field_tmp)
+    end subroutine WriteFieldI_3d
+
+    subroutine WriteFieldI_2d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:) :: Field 
+      integer, dimension(2) :: Dim
+      integer,dimension(3) :: Dim_tmp
+      integer :: i
+      
+      real, allocatable, dimension(:,:) :: Field_tmp 
+      
+      Dim=shape(Field)
+      allocate(Field_tmp(iim*jjm,Dim(2)))
+      field_tmp(:,:)=undef_var
+      
+      do i=1,NbPoint
+        field_tmp(Index_Write_Field(i),:)=Field(i,:)
+      enddo
+      
+      Dim_tmp(1)=iim
+      Dim_tmp(2)=jjm
+      Dim_tmp(3)=dim(2)
+
+      call WriteField_gen(name,Field_tmp,3,Dim_tmp)  
+  
+      deallocate(Field_tmp)
+    end subroutine WriteFieldI_2d
+
+    subroutine WriteFieldI_1d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:) :: Field 
+      integer, dimension(1) :: Dim
+      integer,dimension(2) :: Dim_tmp
+      integer :: i
+      
+      real, allocatable, dimension(:) :: Field_tmp 
+      
+      Dim=shape(Field)
+      allocate(Field_tmp(iim*jjm))
+      field_tmp(:)=undef_var
+      
+      do i=1,NbPoint
+        field_tmp(Index_Write_Field(i))=Field(i)
+      enddo
+      
+      Dim_tmp(1)=iim
+      Dim_tmp(2)=jjm
+
+      call WriteField_gen(name,Field_tmp,2,Dim_tmp)  
+  
+      deallocate(Field_tmp)
+    end subroutine WriteFieldI_1d
+        
+    subroutine WriteField_4d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:,:,:) :: Field 
+      integer, dimension(4) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,4,Dim)  
+  
+    end subroutine WriteField_4d
+     
+    subroutine WriteField_3d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:,:) :: Field 
+      integer, dimension(3) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,3,Dim)  
+  
+    end subroutine WriteField_3d
+    
+    subroutine WriteField_2d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:) :: Field 
+      integer, dimension(2) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,2,Dim)  
+  
+    end subroutine WriteField_2d
+    
+    subroutine WriteField_1d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:) :: Field 
+      integer, dimension(1) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,1,Dim)  
+  
+    end subroutine WriteField_1d
+        
+    subroutine CreateNewField(name,NbDim,DimSize)
+    USE ioipsl
+    implicit none
+    include 'netcdf.inc'  
+      character(len=*) :: name
+      integer :: NbDim
+      integer :: DimSize(NbDim)
+      integer :: TabDim(NbDim+1)
+      integer :: status
+      
+      
+      NbField=NbField+1
+      FieldName(NbField)=TRIM(ADJUSTL(name))
+      FieldIndex(NbField)=1
+      
+      WRITE(numout,*) 'CREATE_NEW_FIELD ',name,NbDim,DimSize
+!      CALL flush(6)
+      status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField))
+      if (NbDim>=1) status = NF_DEF_DIM(FieldId(NbField),'I',DimSize(1),TabDim(1))
+      if (NbDim>=2) status = NF_DEF_DIM(FieldId(NbField),'J',DimSize(2),TabDim(2))
+      if (NbDim>=3) status = NF_DEF_DIM(FieldId(NbField),'K',DimSize(3),TabDim(3))
+      if (NbDim>=4) status = NF_DEF_DIM(FieldId(NbField),'L',DimSize(4),TabDim(4))
+      status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(NbDim+1))
+      status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,NbDim+1,TabDim,FieldVarId(NbField))
+      status = NF_ENDDEF(FieldId(NbField))
+
+    end subroutine CreateNewField
+    
+  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 Orch_Write_Field
+
+    subroutine WriteField_gen(name,Field,NbDim,DimSize)
+    use orch_write_field
+    implicit none
+    include 'netcdf.inc'
+      character(len=*) :: name
+      integer :: NbDim
+      integer,dimension(NbDim) :: DimSize
+      real,dimension(*) :: Field
+      
+      integer :: status
+      integer :: ind
+      integer :: start(NbDim+1)
+      integer :: count(NbDim+1)
+      integer :: i
+           
+      Ind=GetFieldIndex(name)
+      if (Ind==-1) then
+        call CreateNewField(name,NbDim,DimSize)
+	Ind=GetFieldIndex(name)
+      else
+        FieldIndex(Ind)=FieldIndex(Ind)+1
+      endif
+      
+      do i=1,NbDim
+        start(i)=1
+        count(i)=DimSize(i)
+      enddo
+      start(NbDim+1)=FieldIndex(Ind)
+      count(NbDim+1)=1
+
+      status = NF_PUT_VARA_DOUBLE(FieldId(Ind),FieldVarId(Ind),start,count,Field)
+      status = NF_SYNC(FieldId(Ind))
+      
+    end subroutine WriteField_gen
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/orch_write_field_p.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/orch_write_field_p.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/orch_write_field_p.f90	(revision 55)
@@ -0,0 +1,156 @@
+! Yann Meurdesoif functions for parallel tests.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/orch_write_field_p.f90,v 1.3 2007/09/21 14:13:21 ssipsl Exp $
+!-
+
+MODULE Orch_Write_field_p
+  
+  interface WriteField_p
+    module procedure WriteField_4d_p,WriteField_3d_p,WriteField_2d_p
+  end interface WriteField_p
+ 
+  interface WriteFieldI_p
+    module procedure WriteFieldI_3d_p,WriteFieldI_2d_p,WriteFieldI_1d_p
+  end interface WriteFieldI_p  
+  
+  
+CONTAINS
+
+  SUBROUTINE init_WriteField_p(index_Write_Field_p)
+  USE parallel
+  USE Write_Field, only : Init_WriteField
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: index_Write_Field_p(nbp_loc)
+
+    IF (is_root_prc) CALL Init_WriteField(iim_g,jjm_g,nbp_glo,index_g)
+    
+  END SUBROUTINE init_WriteField_p
+
+  SUBROUTINE WriteField_4d_p(name,Field)
+    USE parallel
+    USE Write_field, only : WriteField
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL, DIMENSION(:,:,:,:) :: Field 
+      INTEGER, DIMENSION(4) :: Dim
+      
+      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(iim_g,jjm_g,Dim(3),Dim(4)))
+      CALL Gather2D(Field,Field_g)
+
+      IF (is_root_prc) CALL WriteField(name,Field_g)  
+      
+      DEALLOCATE(Field_g)
+  END SUBROUTINE WriteField_4d_p
+    
+  SUBROUTINE WriteField_3d_p(name,Field)
+    USE parallel
+    USE Write_field, only : WriteField
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL, DIMENSION(:,:,:) :: Field 
+      INTEGER, DIMENSION(3) :: Dim
+      
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(iim_g,jjm_g,Dim(3)))
+      CALL Gather2D(Field,Field_g)
+
+      IF (is_root_prc) CALL WriteField(name,Field_g)  
+      
+      DEALLOCATE(Field_g)
+  END SUBROUTINE WriteField_3d_p
+
+  SUBROUTINE WriteField_2d_p(name,Field)
+    USE parallel
+    USE Write_field, only : WriteField
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL, DIMENSION(:,:) :: Field 
+      INTEGER, DIMENSION(2) :: Dim
+      
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(iim_g,jjm_g))
+      CALL Gather2D(Field,Field_g)
+
+      IF (is_root_prc) CALL WriteField_gen(name,Field_g)  
+      
+      DEALLOCATE(Field_g)
+  END SUBROUTINE WriteField_2d_p
+
+  SUBROUTINE WriteFieldI_3d_p(name,Field)
+    USE parallel
+    USE Write_field, only : WriteFieldI
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL, DIMENSION(:,:,:) :: Field 
+      INTEGER, DIMENSION(3) :: Dim
+      
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(nbp_glo,Dim(2),Dim(3)))
+      CALL gather(Field,Field_g)
+      
+      IF (is_root_prc) CALL WriteFieldI(name,Field_g)  
+      
+      DEALLOCATE(Field_g)
+  END SUBROUTINE WriteFieldI_3d_p
+
+  SUBROUTINE WriteFieldI_2d_p(name,Field)
+    USE parallel
+    USE Write_field, only : WriteFieldI
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL, DIMENSION(:,:) :: Field 
+      INTEGER, DIMENSION(2) :: Dim
+      
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(nbp_glo,Dim(2)))
+      CALL gather(Field,Field_g)
+      
+      IF (is_root_prc) CALL WriteFieldI(name,Field_g)  
+      
+      DEALLOCATE(Field_g)
+  END SUBROUTINE WriteFieldI_2d_p    
+
+  SUBROUTINE WriteFieldI_1d_p(name,Field)
+    USE parallel
+    USE Write_field, only : WriteFieldI
+    IMPLICIT NONE
+      CHARACTER(len=*) :: name
+      REAL, DIMENSION(:) :: Field 
+      INTEGER, DIMENSION(1) :: Dim
+      
+      REAL, ALLOCATABLE, DIMENSION(:) :: Field_g
+      
+      
+      Dim=shape(Field)
+      
+      ALLOCATE(Field_g(nbp_glo))
+      CALL gather(Field,Field_g)
+      
+      IF (is_root_prc) CALL WriteFieldI(name,Field_g)  
+      
+      DEALLOCATE(Field_g)
+  END SUBROUTINE WriteFieldI_1d_p    
+    
+END MODULE Orch_Write_field_p
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/parallel.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/parallel.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/parallel.f90	(revision 55)
@@ -0,0 +1,14 @@
+! Global module for all parallel modules.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/parallel.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
+!-
+
+MODULE PARALLEL
+
+  USE data_para
+  USE transfert_para
+  USE ioipsl_para
+  USE tools_para
+
+END MODULE PARALLEL
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/src_parallel.h
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/src_parallel.h	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/src_parallel.h	(revision 55)
@@ -0,0 +1,646 @@
+! Redefinition of MPI function if not second underscore in MPI library.
+! One must use -DMPI_SECOND__ in precompilation to activate those definitions.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/src_parallel.h,v 1.3 2009/06/24 10:15:00 ssipsl Exp $
+!-
+
+#ifdef MPI_SECOND__
+
+#define MPI_BARRIER MPI_BARRIER_
+#define MPI_FINALIZE MPI_FINALIZE_
+#define MPI_COMM_SIZE MPI_COMM_SIZE_
+#define MPI_INIT MPI_INIT_
+#define MPI_COMM_RANK MPI_COMM_RANK_
+#define MPI_GATHER MPI_GATHER_
+#define MPI_GATHERV MPI_GATHERV_
+#define MPI_BCAST MPI_BCAST_
+#define MPI_SCATTERV MPI_SCATTERV_
+#define MPI_REDUCE MPI_REDUCE_
+
+#endif
+
+#ifdef NF_SECOND__
+
+
+#define nf_get_varm_double nf_get_varm_double_
+#define nf_get_vara_text nf_get_vara_text_
+#define nf_get_vara_real nf_get_vara_real_
+#define nf_get_varm_int1 nf_get_varm_int1_
+#define nf_get_varm_int2 nf_get_varm_int2_
+#define nf_get_varm_text nf_get_varm_text_
+#define nf_get_varm_real nf_get_varm_real_
+#define nf_get_vars_int1 nf_get_vars_int1_
+#define nf_get_vars_int nf_get_vars_int_
+#define nf_get_vars_double nf_get_vars_double_
+#define nf_get_vars_text nf_get_vars_text_
+#define nf_inq_att nf_inq_att_
+#define nf_inq_attid nf_inq_attid_
+#define nf_inq_atttype nf_inq_atttype_
+#define nf_inq_attname nf_inq_attname_
+#define nf_inq_attlen nf_inq_attlen_
+#define nf_inq nf_inq_
+#define nf_inq_dim nf_inq_dim_
+#define nf_inq_dimlen nf_inq_dimlen_
+#define nf_inq_dimid nf_inq_dimid_
+#define nf_inq_libvers nf_inq_libvers_
+#define nf_inq_format nf_inq_format_
+#define nf_inq_natts nf_inq_natts_
+#define nf_inq_dimname nf_inq_dimname_
+#define nf_inq_base_pe nf_inq_base_pe_
+#define nf_get_vars_real nf_get_vars_real_
+#define nf_inq_nvars nf_inq_nvars_
+#define nf_inq_ndims nf_inq_ndims_
+#define nf_get_vars_int2 nf_get_vars_int2_
+#define nf_inq_var nf_inq_var_
+#define nf_inq_vardimid nf_inq_vardimid_
+#define nf_inq_varid nf_inq_varid_
+#define nf_inq_varnatts nf_inq_varnatts_
+#define nf_inq_varndims nf_inq_varndims_
+#define nf_inq_vartype nf_inq_vartype_
+#define nf_inq_varname nf_inq_varname_
+#define nf_issyserr nf_issyserr_
+#define nf_put_att_double nf_put_att_double_
+#define nf_open nf_open_
+#define nf_put_att_int1 nf_put_att_int1_
+#define nf_put_att_int nf_put_att_int_
+#define nf_put_att_text nf_put_att_text_
+#define nf_put_att_real nf_put_att_real_
+#define nf_put_att_int2 nf_put_att_int2_
+#define nf_inq_unlimdim nf_inq_unlimdim_
+#define nf_get_varm_int nf_get_varm_int_
+#define nf_put_var1_int nf_put_var1_int_
+#define nf_put_var1_int2 nf_put_var1_int2_
+#define nf_put_var1_int1 nf_put_var1_int1_
+#define nf_put_var1_text nf_put_var1_text_
+#define nf_put_var_int nf_put_var_int_
+#define nf_put_var_double nf_put_var_double_
+#define nf_put_var1_real nf_put_var1_real_
+#define nf_put_var_real nf_put_var_real_
+#define nf_put_vara_int2 nf_put_vara_int2_
+#define nf_put_vara_int1 nf_put_vara_int1_
+#define nf_put_vara_int nf_put_vara_int_
+#define nf_put_vara_double nf_put_vara_double_
+#define nf_put_vara_text nf_put_vara_text_
+#define nf_put_varm_int1 nf_put_varm_int1_
+#define nf_put_varm_int2 nf_put_varm_int2_
+#define nf_put_varm_int nf_put_varm_int_
+#define nf_put_varm_double nf_put_varm_double_
+#define nf_put_varm_real nf_put_varm_real_
+#define nf_put_vara_real nf_put_vara_real_
+#define nf_put_var_text nf_put_var_text_
+#define nf_put_var_int2 nf_put_var_int2_
+#define nf_put_var_int1 nf_put_var_int1_
+#define nf_put_vars_double nf_put_vars_double_
+#define nf_put_varm_text nf_put_varm_text_
+#define nf_put_var1_double nf_put_var1_double_
+#define nf_put_vars_int1 nf_put_vars_int1_
+#define nf_put_vars_int2 nf_put_vars_int2_
+#define nf_put_vars_text nf_put_vars_text_
+#define nf_put_vars_real nf_put_vars_real_
+#define nf_rename_att nf_rename_att_
+#define nf_set_base_pe nf_set_base_pe_
+#define nf_rename_var nf_rename_var_
+#define nf_rename_dim nf_rename_dim_
+#define nf_redef nf_redef_
+#define nf_sync nf_sync_
+#define nf_strerror nf_strerror_
+#define nf_set_fill nf_set_fill_
+#define nf_set_default_format nf_set_default_format_
+#define nf_put_vars_int nf_put_vars_int_
+#define nf_get_var_int2 nf_get_var_int2_
+#define nf__create_mp nf__create_mp_
+#define nf__open nf__open_
+#define nf__open_mp nf__open_mp_
+#define nf__enddef nf__enddef_
+#define nf_abort nf_abort_
+#define nf__create nf__create_
+#define nf_copy_att nf_copy_att_
+#define nf_create nf_create_
+#define nf_def_dim nf_def_dim_
+#define nf_copy_var nf_copy_var_
+#define nf_close nf_close_
+#define nf_del_att nf_del_att_
+#define nf_delete nf_delete_
+#define nf_def_var nf_def_var_
+#define nf_enddef nf_enddef_
+#define nf_get_att_real nf_get_att_real_
+#define nf_get_att_double nf_get_att_double_
+#define nf_get_att_int nf_get_att_int_
+#define nf_get_att_int2 nf_get_att_int2_
+#define nf_get_att_int1 nf_get_att_int1_
+#define nf_get_att_text nf_get_att_text_
+#define nf_get_var1_int nf_get_var1_int_
+#define nf_get_var1_int1 nf_get_var1_int1_
+#define nf_get_var1_text nf_get_var1_text_
+#define nf_get_var1_real nf_get_var1_real_
+#define nf_get_var1_int2 nf_get_var1_int2_
+#define nf_get_var1_double nf_get_var1_double_
+#define nf_get_var_int nf_get_var_int_
+#define nf_get_var_int2 nf_get_var_int2_
+#define nf_get_var_real nf_get_var_real_
+#define nf_get_var_int1 nf_get_var_int1_
+#define nf_get_var_text nf_get_var_text_
+#define nf_get_vara_int1 nf_get_vara_int1_
+#define nf_get_vara_int nf_get_vara_int_
+#define nf_get_vara_int2 nf_get_vara_int2_
+#define nf_get_vara_double nf_get_vara_double_
+#define nf_get_var_double nf_get_var_double_
+#define nf_get_varm_int nf_get_varm_int_
+#define nf_get_varm_double nf_get_varm_double_
+#define nf_get_varm_int2 nf_get_varm_int2_
+#define nf_get_vars_double nf_get_vars_double_
+#define nf_get_varm_text nf_get_varm_text_
+#define nf_get_varm_real nf_get_varm_real_
+#define nf_get_varm_int1 nf_get_varm_int1_
+#define nf_get_vara_text nf_get_vara_text_
+#define nf_get_vars_text nf_get_vars_text_
+#define nf_get_vars_real nf_get_vars_real_
+#define nf_get_vars_int2 nf_get_vars_int2_
+#define nf_get_vars_int1 nf_get_vars_int1_
+#define nf_inq_att nf_inq_att_
+#define nf_inq_attid nf_inq_attid_
+#define nf_inq nf_inq_
+#define nf_inq_atttype nf_inq_atttype_
+#define nf_inq_attname nf_inq_attname_
+#define nf_inq_dimlen nf_inq_dimlen_
+#define nf_inq_dimid nf_inq_dimid_
+#define nf_inq_libvers nf_inq_libvers_
+#define nf_inq_format nf_inq_format_
+#define nf_inq_dimname nf_inq_dimname_
+#define nf_inq_dim nf_inq_dim_
+#define nf_inq_base_pe nf_inq_base_pe_
+#define nf_inq_ndims nf_inq_ndims_
+#define nf_inq_unlimdim nf_inq_unlimdim_
+#define nf_inq_nvars nf_inq_nvars_
+#define nf_inq_var nf_inq_var_
+#define nf_inq_natts nf_inq_natts_
+#define nf_inq_varid nf_inq_varid_
+#define nf_inq_varname nf_inq_varname_
+#define nf_inq_varnatts nf_inq_varnatts_
+#define nf_inq_vardimid nf_inq_vardimid_
+#define nf_inq_attlen nf_inq_attlen_
+#define nf_get_vars_int nf_get_vars_int_
+#define nf_get_vara_real nf_get_vara_real_
+#define nf_inq_vartype nf_inq_vartype_
+#define nf_issyserr nf_issyserr_
+#define nf_open nf_open_
+#define nf_put_att_int1 nf_put_att_int1_
+#define nf_put_att_int2 nf_put_att_int2_
+#define nf_put_att_text nf_put_att_text_
+#define nf_put_var1_int nf_put_var1_int_
+#define nf_put_var1_int1 nf_put_var1_int1_
+#define nf_put_var1_double nf_put_var1_double_
+#define nf_put_var1_int2 nf_put_var1_int2_
+#define nf_put_var1_real nf_put_var1_real_
+#define nf_put_att_real nf_put_att_real_
+#define nf_put_var1_text nf_put_var1_text_
+#define nf_put_att_int nf_put_att_int_
+#define nf_put_att_double nf_put_att_double_
+#define nf_put_var_double nf_put_var_double_
+#define nf_put_var_int2 nf_put_var_int2_
+#define nf_put_var_int1 nf_put_var_int1_
+#define nf_put_var_real nf_put_var_real_
+#define nf_put_var_int nf_put_var_int_
+#define nf_inq_varndims nf_inq_varndims_
+#define nf_put_vara_int1 nf_put_vara_int1_
+#define nf_put_vara_text nf_put_vara_text_
+#define nf_put_vara_real nf_put_vara_real_
+#define nf_put_varm_int nf_put_varm_int_
+#define nf_put_varm_double nf_put_varm_double_
+#define nf_put_vara_int2 nf_put_vara_int2_
+#define nf_put_varm_int1 nf_put_varm_int1_
+#define nf_put_varm_real nf_put_varm_real_
+#define nf_put_varm_text nf_put_varm_text_
+#define nf_put_vars_int1 nf_put_vars_int1_
+#define nf_put_vars_int nf_put_vars_int_
+#define nf_put_vars_real nf_put_vars_real_
+#define nf_put_vars_int2 nf_put_vars_int2_
+#define nf_put_vars_text nf_put_vars_text_
+#define nf_put_vars_double nf_put_vars_double_
+#define nf_put_varm_int2 nf_put_varm_int2_
+#define nf_rename_dim nf_rename_dim_
+#define nf_rename_att nf_rename_att_
+#define nf_redef nf_redef_
+#define nf_set_base_pe nf_set_base_pe_
+#define nf_set_default_format nf_set_default_format_
+#define nf_rename_var nf_rename_var_
+#define nf_put_vara_int nf_put_vara_int_
+#define nf_strerror nf_strerror_
+#define nf_set_fill nf_set_fill_
+#define nf_put_var_text nf_put_var_text_
+        
+#define NF_GET_VARM_DOUBLE NF_GET_VARM_DOUBLE_
+#define NF_GET_VARA_TEXT NF_GET_VARA_TEXT_
+#define NF_GET_VARA_REAL NF_GET_VARA_REAL_
+#define NF_GET_VARM_INT1 NF_GET_VARM_INT1_
+#define NF_GET_VARM_INT2 NF_GET_VARM_INT2_
+#define NF_GET_VARM_TEXT NF_GET_VARM_TEXT_
+#define NF_GET_VARM_REAL NF_GET_VARM_REAL_
+#define NF_GET_VARS_INT1 NF_GET_VARS_INT1_
+#define NF_GET_VARS_INT NF_GET_VARS_INT_
+#define NF_GET_VARS_DOUBLE NF_GET_VARS_DOUBLE_
+#define NF_GET_VARS_TEXT NF_GET_VARS_TEXT_
+#define NF_INQ_ATT NF_INQ_ATT_
+#define NF_INQ_ATTID NF_INQ_ATTID_
+#define NF_INQ_ATTTYPE NF_INQ_ATTTYPE_
+#define NF_INQ_ATTNAME NF_INQ_ATTNAME_
+#define NF_INQ_ATTLEN NF_INQ_ATTLEN_
+#define NF_INQ NF_INQ_
+#define NF_INQ_DIM NF_INQ_DIM_
+#define NF_INQ_DIMLEN NF_INQ_DIMLEN_
+#define NF_INQ_DIMID NF_INQ_DIMID_
+#define NF_INQ_LIBVERS NF_INQ_LIBVERS_
+#define NF_INQ_FORMAT NF_INQ_FORMAT_
+#define NF_INQ_NATTS NF_INQ_NATTS_
+#define NF_INQ_DIMNAME NF_INQ_DIMNAME_
+#define NF_INQ_BASE_PE NF_INQ_BASE_PE_
+#define NF_GET_VARS_REAL NF_GET_VARS_REAL_
+#define NF_INQ_NVARS NF_INQ_NVARS_
+#define NF_INQ_NDIMS NF_INQ_NDIMS_
+#define NF_GET_VARS_INT2 NF_GET_VARS_INT2_
+#define NF_INQ_VAR NF_INQ_VAR_
+#define NF_INQ_VARDIMID NF_INQ_VARDIMID_
+#define NF_INQ_VARID NF_INQ_VARID_
+#define NF_INQ_VARNATTS NF_INQ_VARNATTS_
+#define NF_INQ_VARNDIMS NF_INQ_VARNDIMS_
+#define NF_INQ_VARTYPE NF_INQ_VARTYPE_
+#define NF_INQ_VARNAME NF_INQ_VARNAME_
+#define NF_ISSYSERR NF_ISSYSERR_
+#define NF_PUT_ATT_DOUBLE NF_PUT_ATT_DOUBLE_
+#define NF_OPEN NF_OPEN_
+#define NF_PUT_ATT_INT1 NF_PUT_ATT_INT1_
+#define NF_PUT_ATT_INT NF_PUT_ATT_INT_
+#define NF_PUT_ATT_TEXT NF_PUT_ATT_TEXT_
+#define NF_PUT_ATT_REAL NF_PUT_ATT_REAL_
+#define NF_PUT_ATT_INT2 NF_PUT_ATT_INT2_
+#define NF_INQ_UNLIMDIM NF_INQ_UNLIMDIM_
+#define NF_GET_VARM_INT NF_GET_VARM_INT_
+#define NF_PUT_VAR1_INT NF_PUT_VAR1_INT_
+#define NF_PUT_VAR1_INT2 NF_PUT_VAR1_INT2_
+#define NF_PUT_VAR1_INT1 NF_PUT_VAR1_INT1_
+#define NF_PUT_VAR1_TEXT NF_PUT_VAR1_TEXT_
+#define NF_PUT_VAR_INT NF_PUT_VAR_INT_
+#define NF_PUT_VAR_DOUBLE NF_PUT_VAR_DOUBLE_
+#define NF_PUT_VAR1_REAL NF_PUT_VAR1_REAL_
+#define NF_PUT_VAR_REAL NF_PUT_VAR_REAL_
+#define NF_PUT_VARA_INT2 NF_PUT_VARA_INT2_
+#define NF_PUT_VARA_INT1 NF_PUT_VARA_INT1_
+#define NF_PUT_VARA_INT NF_PUT_VARA_INT_
+#define NF_PUT_VARA_DOUBLE NF_PUT_VARA_DOUBLE_
+#define NF_PUT_VARA_TEXT NF_PUT_VARA_TEXT_
+#define NF_PUT_VARM_INT1 NF_PUT_VARM_INT1_
+#define NF_PUT_VARM_INT2 NF_PUT_VARM_INT2_
+#define NF_PUT_VARM_INT NF_PUT_VARM_INT_
+#define NF_PUT_VARM_DOUBLE NF_PUT_VARM_DOUBLE_
+#define NF_PUT_VARM_REAL NF_PUT_VARM_REAL_
+#define NF_PUT_VARA_REAL NF_PUT_VARA_REAL_
+#define NF_PUT_VAR_TEXT NF_PUT_VAR_TEXT_
+#define NF_PUT_VAR_INT2 NF_PUT_VAR_INT2_
+#define NF_PUT_VAR_INT1 NF_PUT_VAR_INT1_
+#define NF_PUT_VARS_DOUBLE NF_PUT_VARS_DOUBLE_
+#define NF_PUT_VARM_TEXT NF_PUT_VARM_TEXT_
+#define NF_PUT_VAR1_DOUBLE NF_PUT_VAR1_DOUBLE_
+#define NF_PUT_VARS_INT1 NF_PUT_VARS_INT1_
+#define NF_PUT_VARS_INT2 NF_PUT_VARS_INT2_
+#define NF_PUT_VARS_TEXT NF_PUT_VARS_TEXT_
+#define NF_PUT_VARS_REAL NF_PUT_VARS_REAL_
+#define NF_RENAME_ATT NF_RENAME_ATT_
+#define NF_SET_BASE_PE NF_SET_BASE_PE_
+#define NF_RENAME_VAR NF_RENAME_VAR_
+#define NF_RENAME_DIM NF_RENAME_DIM_
+#define NF_REDEF NF_REDEF_
+#define NF_SYNC NF_SYNC_
+#define NF_STRERROR NF_STRERROR_
+#define NF_SET_FILL NF_SET_FILL_
+#define NF_SET_DEFAULT_FORMAT NF_SET_DEFAULT_FORMAT_
+#define NF_PUT_VARS_INT NF_PUT_VARS_INT_
+#define NF_GET_VAR_INT2 NF_GET_VAR_INT2_
+#define NF__CREATE_MP NF__CREATE_MP_
+#define NF__OPEN NF__OPEN_
+#define NF__OPEN_MP NF__OPEN_MP_
+#define NF__ENDDEF NF__ENDDEF_
+#define NF_ABORT NF_ABORT_
+#define NF__CREATE NF__CREATE_
+#define NF_COPY_ATT NF_COPY_ATT_
+#define NF_CREATE NF_CREATE_
+#define NF_DEF_DIM NF_DEF_DIM_
+#define NF_COPY_VAR NF_COPY_VAR_
+#define NF_CLOSE NF_CLOSE_
+#define NF_DEL_ATT NF_DEL_ATT_
+#define NF_DELETE NF_DELETE_
+#define NF_DEF_VAR NF_DEF_VAR_
+#define NF_ENDDEF NF_ENDDEF_
+#define NF_GET_ATT_REAL NF_GET_ATT_REAL_
+#define NF_GET_ATT_DOUBLE NF_GET_ATT_DOUBLE_
+#define NF_GET_ATT_INT NF_GET_ATT_INT_
+#define NF_GET_ATT_INT2 NF_GET_ATT_INT2_
+#define NF_GET_ATT_INT1 NF_GET_ATT_INT1_
+#define NF_GET_ATT_TEXT NF_GET_ATT_TEXT_
+#define NF_GET_VAR1_INT NF_GET_VAR1_INT_
+#define NF_GET_VAR1_INT1 NF_GET_VAR1_INT1_
+#define NF_GET_VAR1_TEXT NF_GET_VAR1_TEXT_
+#define NF_GET_VAR1_REAL NF_GET_VAR1_REAL_
+#define NF_GET_VAR1_INT2 NF_GET_VAR1_INT2_
+#define NF_GET_VAR1_DOUBLE NF_GET_VAR1_DOUBLE_
+#define NF_GET_VAR_INT NF_GET_VAR_INT_
+#define NF_GET_VAR_INT2 NF_GET_VAR_INT2_
+#define NF_GET_VAR_REAL NF_GET_VAR_REAL_
+#define NF_GET_VAR_INT1 NF_GET_VAR_INT1_
+#define NF_GET_VAR_TEXT NF_GET_VAR_TEXT_
+#define NF_GET_VARA_INT1 NF_GET_VARA_INT1_
+#define NF_GET_VARA_INT NF_GET_VARA_INT_
+#define NF_GET_VARA_INT2 NF_GET_VARA_INT2_
+#define NF_GET_VARA_DOUBLE NF_GET_VARA_DOUBLE_
+#define NF_GET_VAR_DOUBLE NF_GET_VAR_DOUBLE_
+#define NF_GET_VARM_INT NF_GET_VARM_INT_
+#define NF_GET_VARM_DOUBLE NF_GET_VARM_DOUBLE_
+#define NF_GET_VARM_INT2 NF_GET_VARM_INT2_
+#define NF_GET_VARS_DOUBLE NF_GET_VARS_DOUBLE_
+#define NF_GET_VARM_TEXT NF_GET_VARM_TEXT_
+#define NF_GET_VARM_REAL NF_GET_VARM_REAL_
+#define NF_GET_VARM_INT1 NF_GET_VARM_INT1_
+#define NF_GET_VARA_TEXT NF_GET_VARA_TEXT_
+#define NF_GET_VARS_TEXT NF_GET_VARS_TEXT_
+#define NF_GET_VARS_REAL NF_GET_VARS_REAL_
+#define NF_GET_VARS_INT2 NF_GET_VARS_INT2_
+#define NF_GET_VARS_INT1 NF_GET_VARS_INT1_
+#define NF_INQ_ATT NF_INQ_ATT_
+#define NF_INQ_ATTID NF_INQ_ATTID_
+#define NF_INQ NF_INQ_
+#define NF_INQ_ATTTYPE NF_INQ_ATTTYPE_
+#define NF_INQ_ATTNAME NF_INQ_ATTNAME_
+#define NF_INQ_DIMLEN NF_INQ_DIMLEN_
+#define NF_INQ_DIMID NF_INQ_DIMID_
+#define NF_INQ_LIBVERS NF_INQ_LIBVERS_
+#define NF_INQ_FORMAT NF_INQ_FORMAT_
+#define NF_INQ_DIMNAME NF_INQ_DIMNAME_
+#define NF_INQ_DIM NF_INQ_DIM_
+#define NF_INQ_BASE_PE NF_INQ_BASE_PE_
+#define NF_INQ_NDIMS NF_INQ_NDIMS_
+#define NF_INQ_UNLIMDIM NF_INQ_UNLIMDIM_
+#define NF_INQ_NVARS NF_INQ_NVARS_
+#define NF_INQ_VAR NF_INQ_VAR_
+#define NF_INQ_NATTS NF_INQ_NATTS_
+#define NF_INQ_VARID NF_INQ_VARID_
+#define NF_INQ_VARNAME NF_INQ_VARNAME_
+#define NF_INQ_VARNATTS NF_INQ_VARNATTS_
+#define NF_INQ_VARDIMID NF_INQ_VARDIMID_
+#define NF_INQ_ATTLEN NF_INQ_ATTLEN_
+#define NF_GET_VARS_INT NF_GET_VARS_INT_
+#define NF_GET_VARA_REAL NF_GET_VARA_REAL_
+#define NF_INQ_VARTYPE NF_INQ_VARTYPE_
+#define NF_ISSYSERR NF_ISSYSERR_
+#define NF_OPEN NF_OPEN_
+#define NF_PUT_ATT_INT1 NF_PUT_ATT_INT1_
+#define NF_PUT_ATT_INT2 NF_PUT_ATT_INT2_
+#define NF_PUT_ATT_TEXT NF_PUT_ATT_TEXT_
+#define NF_PUT_VAR1_INT NF_PUT_VAR1_INT_
+#define NF_PUT_VAR1_INT1 NF_PUT_VAR1_INT1_
+#define NF_PUT_VAR1_DOUBLE NF_PUT_VAR1_DOUBLE_
+#define NF_PUT_VAR1_INT2 NF_PUT_VAR1_INT2_
+#define NF_PUT_VAR1_REAL NF_PUT_VAR1_REAL_
+#define NF_PUT_ATT_REAL NF_PUT_ATT_REAL_
+#define NF_PUT_VAR1_TEXT NF_PUT_VAR1_TEXT_
+#define NF_PUT_ATT_INT NF_PUT_ATT_INT_
+#define NF_PUT_ATT_DOUBLE NF_PUT_ATT_DOUBLE_
+#define NF_PUT_VAR_DOUBLE NF_PUT_VAR_DOUBLE_
+#define NF_PUT_VAR_INT2 NF_PUT_VAR_INT2_
+#define NF_PUT_VAR_INT1 NF_PUT_VAR_INT1_
+#define NF_PUT_VAR_REAL NF_PUT_VAR_REAL_
+#define NF_PUT_VAR_INT NF_PUT_VAR_INT_
+#define NF_INQ_VARNDIMS NF_INQ_VARNDIMS_
+#define NF_PUT_VARA_INT1 NF_PUT_VARA_INT1_
+#define NF_PUT_VARA_TEXT NF_PUT_VARA_TEXT_
+#define NF_PUT_VARA_REAL NF_PUT_VARA_REAL_
+#define NF_PUT_VARM_INT NF_PUT_VARM_INT_
+#define NF_PUT_VARM_DOUBLE NF_PUT_VARM_DOUBLE_
+#define NF_PUT_VARA_INT2 NF_PUT_VARA_INT2_
+#define NF_PUT_VARM_INT1 NF_PUT_VARM_INT1_
+#define NF_PUT_VARM_REAL NF_PUT_VARM_REAL_
+#define NF_PUT_VARM_TEXT NF_PUT_VARM_TEXT_
+#define NF_PUT_VARS_INT1 NF_PUT_VARS_INT1_
+#define NF_PUT_VARS_INT NF_PUT_VARS_INT_
+#define NF_PUT_VARS_REAL NF_PUT_VARS_REAL_
+#define NF_PUT_VARS_INT2 NF_PUT_VARS_INT2_
+#define NF_PUT_VARS_TEXT NF_PUT_VARS_TEXT_
+#define NF_PUT_VARS_DOUBLE NF_PUT_VARS_DOUBLE_
+#define NF_PUT_VARM_INT2 NF_PUT_VARM_INT2_
+#define NF_RENAME_DIM NF_RENAME_DIM_
+#define NF_RENAME_ATT NF_RENAME_ATT_
+#define NF_REDEF NF_REDEF_
+#define NF_SET_BASE_PE NF_SET_BASE_PE_
+#define NF_SET_DEFAULT_FORMAT NF_SET_DEFAULT_FORMAT_
+#define NF_RENAME_VAR NF_RENAME_VAR_
+#define NF_PUT_VARA_INT NF_PUT_VARA_INT_
+#define NF_STRERROR NF_STRERROR_
+#define NF_SET_FILL NF_SET_FILL_
+#define NF_PUT_VAR_TEXT NF_PUT_VAR_TEXT_
+
+#endif
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/timer.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/timer.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/timer.f90	(revision 55)
@@ -0,0 +1,174 @@
+! Timer functions to calculate MPI use speed up.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/timer.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
+!-
+
+MODULE timer
+
+  USE data_para
+  
+  INTEGER, PARAMETER :: nb_timer=2
+  INTEGER, PARAMETER :: timer_global=1
+  INTEGER, PARAMETER :: timer_mpi=2
+  INTEGER, PARAMETER :: stopped = 1
+  INTEGER, PARAMETER :: running = 2
+  INTEGER, PARAMETER :: suspended = 3
+  
+  DOUBLE PRECISION, DIMENSION(nb_timer),SAVE :: cpu_timer
+  DOUBLE PRECISION, DIMENSION(nb_timer),SAVE :: real_timer
+  INTEGER, DIMENSION(nb_timer),SAVE :: timer_state
+  DOUBLE PRECISION, DIMENSION(nb_timer),SAVE :: last_cpu_time
+  INTEGER, DIMENSION(nb_timer),SAVE :: last_real_time
+  
+  
+  
+  
+  CONTAINS
+  
+  SUBROUTINE init_timer
+  IMPLICIT NONE
+    
+    cpu_timer(:)=0.
+    real_timer(:)=0.
+    timer_state(:)=stopped
+    last_cpu_time(:)=0.
+    last_real_time(:)=0
+    
+  END SUBROUTINE init_timer
+  
+  
+  SUBROUTINE start_timer(no_timer)
+  IMPLICIT NONE
+     INTEGER :: no_timer
+     DOUBLE PRECISION :: x
+     
+     IF (timer_state(no_timer)/=stopped) THEN
+       STOP 'start_timer :: timer is already running or suspended'
+     ELSE
+        timer_state(no_timer)=running
+     ENDIF
+      
+     cpu_timer(no_timer)=0. 
+     real_timer(no_timer)=0.
+     x=Diff_real_time(no_timer)
+     x=Diff_cpu_time(no_timer)
+     
+  END SUBROUTINE start_timer
+  
+  
+  
+  SUBROUTINE stop_timer(no_timer)
+  IMPLICIT NONE
+    INTEGER :: no_timer
+    
+     IF (timer_state(no_timer)==running) THEN
+        CALL suspend_timer(no_timer)
+     ELSE IF (timer_state(no_timer)==stopped) THEN
+       WRITE(numout,*) 'stop_timer :: timer is already stopped'
+     ENDIF
+
+     timer_state(no_timer)=stopped
+
+  END SUBROUTINE stop_timer
+  
+  
+  
+  SUBROUTINE resume_timer(no_timer)
+  IMPLICIT NONE
+    INTEGER :: no_timer
+    DOUBLE PRECISION :: x
+     IF (timer_state(no_timer)/=suspended) THEN
+       STOP 'resume_timer :: timer is not suspended'
+     ELSE
+        timer_state(no_timer)=running
+     ENDIF
+  
+     x=Diff_cpu_time(no_timer)
+     x=Diff_real_time(no_timer)  
+  
+  END SUBROUTINE resume_timer
+  
+  
+  
+  SUBROUTINE suspend_timer(no_timer)
+  
+    IMPLICIT NONE
+    INTEGER :: no_timer
+    
+     IF (timer_state(no_timer)/=running) THEN
+       STOP 'suspend_timer :: timer is not running'
+     ELSE
+        timer_state(no_timer)=suspended
+     ENDIF
+  
+     cpu_timer(no_timer)=cpu_timer(no_timer)+Diff_cpu_time(no_timer)
+     real_timer(no_timer)=real_timer(no_timer)+Diff_real_time(no_timer)
+  
+  END SUBROUTINE suspend_timer
+  
+  
+  FUNCTION diff_real_time(no_timer)
+  IMPLICIT NONE
+    INTEGER :: no_timer
+    DOUBLE PRECISION :: Diff_real_Time
+    integer :: Last_Count,count,count_rate,count_max
+    
+    Last_Count=Last_real_time(no_timer)
+    
+    call system_clock(count,count_rate,count_max)
+    if (Count>=Last_Count) then
+      Diff_real_time=(1.*(Count-last_Count))/count_rate
+    else
+      Diff_real_time=(1.*(Count-last_Count+Count_max))/count_rate
+    endif
+    Last_real_time(no_timer)=Count 
+    
+  END FUNCTION diff_real_time
+  
+  function Diff_Cpu_Time(no_timer)
+  implicit none
+    INTEGER :: no_timer
+    DOUBLE PRECISION :: Diff_Cpu_Time
+    DOUBLE PRECISION :: Last_Count,Count
+    
+    Last_Count=Last_cpu_time(no_timer)
+    
+    call cpu_time(Count)
+    Diff_Cpu_Time=Count-Last_Count
+    Last_cpu_time(no_timer)=Count 
+    
+  end function Diff_Cpu_Time
+  
+  FUNCTION Get_cpu_time(no_timer)
+  IMPLICIT NONE
+  INTEGER :: no_timer
+  DOUBLE PRECISION :: Get_cpu_time
+  
+    IF (timer_state(no_timer)==running) THEN
+      CALL suspend_timer(no_timer)
+      Get_cpu_time=cpu_timer(no_timer)
+      CALL resume_timer(no_timer)
+    ELSE
+      Get_cpu_time=cpu_timer(no_timer)
+    ENDIF
+    
+  END FUNCTION Get_cpu_time
+  
+  FUNCTION Get_real_time(no_timer)
+  IMPLICIT NONE
+  INTEGER :: no_timer
+  DOUBLE PRECISION :: Get_real_time
+  
+    IF (timer_state(no_timer)==running) THEN
+      CALL suspend_timer(no_timer)
+      Get_real_time=real_timer(no_timer)
+      CALL resume_timer(no_timer)
+    ELSE
+      Get_real_time=real_timer(no_timer)
+    ENDIF
+  
+  END FUNCTION Get_real_time
+  
+END MODULE Timer
+  
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/tools_para.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/tools_para.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/tools_para.f90	(revision 55)
@@ -0,0 +1,52 @@
+! Parallel tools : Barrier and Finalize.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/tools_para.f90,v 1.3 2008/10/13 14:19:47 ssipsl Exp $
+!-
+
+MODULE tools_para
+!-
+  USE ioipsl
+  USE defprec
+  USE timer
+  USE data_para
+!-
+#include "src_parallel.h"
+!-
+CONTAINS
+  SUBROUTINE stop_mpi()
+#ifdef CPP_PARA
+    CALL MPI_COMM_FREE(MPI_COMM_ORCH,ierr)
+    CALL MPI_FINALIZE(ierr)
+#endif
+    CALL ipslerr(3,'STOP_MPI','MPI has been stopped in ORCHIDEE.',&
+ &                 "Don't know the reason","Please verify output.")
+  ENd subroutine stop_mpi
+
+  SUBROUTINE barrier_para()
+#ifdef CPP_PARA
+    CALL MPI_BARRIER(MPI_COMM_ORCH,ierr)
+#endif
+  END SUBROUTINE barrier_para
+
+  SUBROUTINE finalize_para(timer_global,timer_mpi)
+    INTEGER, INTENT(IN) :: timer_global, timer_mpi
+    DOUBLE PRECISION :: cpu_time_mpi
+
+    cpu_time_mpi = Get_cpu_time(timer_mpi)
+    WRITE(numout,*) '*********************************************************'
+    WRITE(numout,*) ' TEMPS GLOBAL   ---> REAL TIME :',Get_real_time(timer_global)
+    WRITE(numout,*) ' TEMPS GLOBAL   ---> CPU TIME  :',Get_cpu_time(timer_global)
+    WRITE(numout,*) ' TEMPS HORS MPI ---> REAL TIME :',Get_real_time(timer_mpi)
+    WRITE(numout,*) ' TEMPS HORS MPI ---> CPU TIME  :',cpu_time_mpi
+    WRITE(numout,*) '*********************************************************' 
+    WRITE(numout,*) 'END OF RUN.'
+
+    CALL Write_Load_Balance(REAL(cpu_time_mpi, r_std))
+#ifdef CPP_PARA
+!    CALL MPI_COMM_FREE(MPI_COMM_ORCH,ierr)
+    CALL MPI_FINALIZE(ierr)
+#endif
+  END SUBROUTINE finalize_para
+
+END MODULE tools_para
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/transfert_para.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/transfert_para.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/transfert_para.f90	(revision 55)
@@ -0,0 +1,2943 @@
+! Low level parallel communication encapsulations for ORCHIDEE.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/transfert_para.f90,v 1.6 2009/03/25 16:08:52 ssipsl Exp $
+!-
+
+MODULE transfert_para
+
+  USE data_para
+  USE timer
+!-
+  IMPLICIT NONE
+!-
+#include "src_parallel.h"
+!-
+
+  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_s
+    MODULE PROCEDURE gather_is, &
+                     gather_rs, &
+		     gather_ls
+  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_r0,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_r0,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(var1)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var1
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_cgen(Var1,len(Var1))
+#endif
+  END SUBROUTINE bcast_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_i(var1)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var1
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_igen(Var1,1)
+#endif
+  END SUBROUTINE bcast_i
+
+  SUBROUTINE bcast_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_i1
+
+  SUBROUTINE bcast_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_i2
+
+  SUBROUTINE bcast_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_i3
+
+  SUBROUTINE bcast_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_igen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_rgen(Var,1)
+#endif
+  END SUBROUTINE bcast_r
+
+  SUBROUTINE bcast_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_r1
+
+  SUBROUTINE bcast_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_r2
+
+  SUBROUTINE bcast_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_r3
+
+  SUBROUTINE bcast_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_rgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_r4
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_lgen(Var,1)
+#endif
+  END SUBROUTINE bcast_l
+
+  SUBROUTINE bcast_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_l1
+
+  SUBROUTINE bcast_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_l2
+
+  SUBROUTINE bcast_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_l3
+
+  SUBROUTINE bcast_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#else
+    CALL bcast_lgen(Var,size(Var))
+#endif
+  END SUBROUTINE bcast_l4
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(nbp_glo) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_loc) :: VarOut
+
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+     IF (is_root_prc) THEN
+      CALL scatter_igen(VarIn,Varout,1)
+     ELSE
+      CALL scatter_igen(dummy,Varout,1)
+    ENDIF
+    
+#endif
+  END SUBROUTINE scatter_i
+
+  SUBROUTINE scatter_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_igen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_igen(dummy,Varout,Size(VarOut,2))
+    ENDIF
+    
+#endif
+  END SUBROUTINE scatter_i1
+  
+  SUBROUTINE scatter_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+#endif
+  END SUBROUTINE scatter_i2
+
+  SUBROUTINE scatter_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_i3
+
+
+  SUBROUTINE scatter_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_rgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_rgen(dummy,Varout,1)
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_r
+
+  SUBROUTINE scatter_r1(VarIn, VarOut)
+
+  IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_rgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_rgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_r1
+  
+  SUBROUTINE scatter_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_r2
+
+  SUBROUTINE scatter_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_r3
+
+
+  SUBROUTINE scatter_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+#ifdef CPP_PARA    
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_lgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_lgen(dummy,Varout,1)
+    ENDIF
+    
+#endif
+  END SUBROUTINE scatter_l
+
+  SUBROUTINE scatter_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_lgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_lgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_l1
+  
+  SUBROUTINE scatter_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_l2
+
+  SUBROUTINE scatter_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+    IF (is_root_prc) THEN
+      CALL scatter_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter_l3  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather_is(VarIn, VarOut)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    
+    INTEGER,INTENT(IN) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+  
+#ifdef CPP_PARA
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn
+    RETURN
+#else
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarIn=",VarIn    
+
+#ifdef CPP_PARA
+    CALL MPI_GATHER(VarIn,1,MPI_INT_ORCH,VarOut,1,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+#endif
+
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarOut=",VarOut
+    IF (flag) CALL resume_timer(timer_mpi)
+#endif
+  END SUBROUTINE gather_is
+
+  SUBROUTINE gather_rs(VarIn, VarOut)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+
+    REAL,INTENT(IN) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+  
+#ifdef CPP_PARA
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn
+    RETURN
+#else
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarIn=",VarIn    
+
+#ifdef CPP_PARA
+    CALL MPI_GATHER(VarIn,1,MPI_REAL_ORCH,VarOut,1,MPI_REAL_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+#endif
+
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarOut=",VarOut
+
+    IF (flag) CALL resume_timer(timer_mpi)
+#endif
+  END SUBROUTINE gather_rs
+
+  SUBROUTINE gather_ls(VarIn, VarOut)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    
+    LOGICAL,INTENT(IN) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+  
+#ifdef CPP_PARA
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn
+    RETURN
+#else
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarIn=",VarIn    
+
+#ifdef CPP_PARA
+    CALL MPI_GATHER(VarIn,1,MPI_LOGICAL,VarOut,1,MPI_LOGICAL,root_prc,MPI_COMM_ORCH,ierr)
+#endif
+
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarOut=",VarOut
+    IF (flag) CALL resume_timer(timer_mpi)
+#endif
+  END SUBROUTINE gather_ls
+
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+!    if (SIZE(VarIn) == 1) call stopit
+    IF (is_root_prc) THEN
+      CALL gather_igen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_igen(VarIn,dummy,1)
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_i
+
+!!!!!
+
+  SUBROUTINE gather_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+!    if (SIZE(VarIn) == 1) stop
+    IF (is_root_prc) THEN
+      CALL gather_igen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_igen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_i1
+
+!!!!!
+  
+  SUBROUTINE gather_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_i2
+
+!!!!!
+
+  SUBROUTINE gather_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_i3
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+!    if (SIZE(VarIn) == 1) call stopit
+    IF (is_root_prc) THEN
+      CALL gather_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_rgen(VarIn,dummy,1)
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_r
+
+!!!!!
+
+  SUBROUTINE gather_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_rgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_rgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_r1
+
+!!!!!
+  
+  SUBROUTINE gather_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_r2
+
+!!!!!
+
+  SUBROUTINE gather_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_r3
+
+!!!!! --> Les booleen
+
+  SUBROUTINE gather_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+!    if (SIZE(VarIn) == 1) call stopit
+    IF (is_root_prc) THEN
+      CALL gather_lgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_lgen(VarIn,dummy,1)      
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_l
+
+!!!!!
+
+  SUBROUTINE gather_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_lgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_lgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_l1
+
+!!!!!
+  
+  SUBROUTINE gather_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_l2
+
+!!!!!
+
+  SUBROUTINE gather_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE gather_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter2D_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_igen(VarIn,VarOut,1)
+    ELSE
+      CALL scatter2D_igen(dummy,VarOut,1)
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_i
+
+  SUBROUTINE scatter2D_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_igen(VarIn,VarOut,SIZE(VarOut,3))
+    ELSE
+      CALL scatter2D_igen(dummy,VarOut,SIZE(VarOut,3))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_i1
+
+  SUBROUTINE scatter2D_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_igen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+      CALL scatter2D_igen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_i2
+  
+  SUBROUTINE scatter2D_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_igen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ELSE
+      CALL scatter2D_igen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_i3
+
+
+  SUBROUTINE scatter2D_r0(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL scatter2D_rgen(dummy,VarOut,1)      
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_r0
+
+  SUBROUTINE scatter2D_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL scatter2D_rgen(dummy,VarOut,1)      
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_r
+
+  SUBROUTINE scatter2D_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_rgen(VarIn,VarOut,SIZE(VarOut,3))
+    ELSE
+      CALL scatter2D_rgen(dummy,VarOut,SIZE(VarOut,3))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_r1
+
+  SUBROUTINE scatter2D_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_rgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+      CALL scatter2D_rgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_r2
+  
+  SUBROUTINE scatter2D_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_rgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ELSE
+      CALL scatter2D_rgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_r3  
+  
+  
+  SUBROUTINE scatter2D_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_lgen(VarIn,VarOut,1)
+    ELSE
+      CALL scatter2D_lgen(dummy,VarOut,1)
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_l
+
+  SUBROUTINE scatter2D_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA    
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_lgen(VarIn,VarOut,SIZE(VarOut,3))
+    ELSE
+      CALL scatter2D_lgen(dummy,VarOut,SIZE(VarOut,3))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE scatter2D_l1
+
+  SUBROUTINE scatter2D_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_lgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ELSE
+      CALL scatter2D_lgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4))
+    ENDIF
+  
+#endif
+  END SUBROUTINE scatter2D_l2
+  
+  SUBROUTINE scatter2D_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    LOGICAL :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL scatter2D_lgen(VarIn,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ELSE
+      CALL scatter2D_lgen(dummy,VarOut,SIZE(VarOut,3)*SIZE(VarOut,4)*SIZE(VarOut,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE scatter2D_l3 
+  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather2D_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_igen(VarIn,VarOut,1)
+    ELSE
+      CALL gather2D_igen(VarIn,dummy,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_i
+
+  SUBROUTINE gather2D_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_igen(VarIn,VarOut,SIZE(VarIn,3))
+    ELSE
+      CALL gather2D_igen(VarIn,dummy,SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_i1
+
+  SUBROUTINE gather2D_i2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_igen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+      CALL gather2D_igen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_i2
+  
+  SUBROUTINE gather2D_i3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_igen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ELSE
+      CALL gather2D_igen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_i3
+
+
+  SUBROUTINE gather2D_r0(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather2D_rgen(VarIn,dummy,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_r0
+
+  SUBROUTINE gather2D_r(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather2D_rgen(VarIn,dummy,1)
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_r
+
+  SUBROUTINE gather2D_r1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_rgen(VarIn,VarOut,SIZE(VarIn,3))
+    ELSE
+      CALL gather2D_rgen(VarIn,dummy,SIZE(VarIn,3))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_r1
+
+  SUBROUTINE gather2D_r2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_rgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+      CALL gather2D_rgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+
+#endif
+  END SUBROUTINE gather2D_r2
+  
+  SUBROUTINE gather2D_r3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_rgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ELSE
+      CALL gather2D_rgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE gather2D_r3  
+  
+  
+  SUBROUTINE gather2D_l(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_lgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather2D_lgen(VarIn,dummy,1)
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE gather2D_l
+
+  SUBROUTINE gather2D_l1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA    
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_lgen(VarIn,VarOut,SIZE(VarIn,3))
+    ELSE
+      CALL gather2D_lgen(VarIn,dummy,SIZE(VarIn,3))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE gather2D_l1
+
+  SUBROUTINE gather2D_l2(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+#ifdef CPP_PARA    
+    LOGICAL :: dummy
+#endif
+
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_lgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ELSE
+      CALL gather2D_lgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE gather2D_l2
+  
+  SUBROUTINE gather2D_l3(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA    
+    LOGICAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:,:)=VarIn(:,:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL gather2D_lgen(VarIn,VarOut,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ELSE
+      CALL gather2D_lgen(VarIn,dummy,SIZE(VarIn,3)*SIZE(VarIn,4)*SIZE(VarIn,5))
+    ENDIF
+  
+
+#endif
+  END SUBROUTINE gather2D_l3  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE reduce_sum_i(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_igen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_igen(VarIn,dummy,1)
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_i
+
+  SUBROUTINE reduce_sum_i1(VarIn, VarOut)
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_i1
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_i2
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_i3
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    INTEGER :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_i4                  
+  
+  
+  SUBROUTINE reduce_sum_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_rgen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_rgen(VarIn,dummy,1)
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_r
+
+  SUBROUTINE reduce_sum_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_r1
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_r2
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_r3
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+#ifdef CPP_PARA
+    REAL :: dummy
+#endif
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#else
+
+    IF (is_root_prc) THEN
+      CALL reduce_sum_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+#endif
+  END SUBROUTINE reduce_sum_r4 
+  
+                            
+END MODULE transfert_para    
+
+#ifdef CPP_PARA
+
+  SUBROUTINE bcast_cgen(var,nb)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+    INCLUDE 'mpif.h'
+
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (check) &
+         WRITE(numout,*) "bcast_cgen before bcast Var",Var
+    IF (flag) CALL suspend_timer(timer_mpi)
+    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,root_prc,MPI_COMM_ORCH,ierr)
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+         WRITE(numout,*) "bcast_cgen after bcast Var",Var
+        
+  END SUBROUTINE bcast_cgen
+      
+  SUBROUTINE bcast_igen(var,nb)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+    
+    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+    INCLUDE 'mpif.h'
+
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+   
+    IF (check) &
+         WRITE(numout,*) "bcast_igen before bcast Var",Var
+    CALL MPI_BCAST(Var,nb,MPI_INT_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+         WRITE(numout,*) "bcast_igen after bcast Var",Var    
+        
+  END SUBROUTINE bcast_igen
+  
+  SUBROUTINE bcast_rgen(var,nb)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+    
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+    INCLUDE 'mpif.h'
+
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (check) &
+         WRITE(numout,*) "bcast_rgen before bcast Var",Var
+    IF (flag) CALL suspend_timer(timer_mpi)    
+    CALL MPI_BCAST(Var,nb,MPI_REAL_ORCH,root_prc,MPI_COMM_ORCH,ierr)
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+         WRITE(numout,*) "bcast_rgen after bcast Var",Var
+    
+  END SUBROUTINE bcast_rgen
+  
+  SUBROUTINE bcast_lgen(var,nb)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+    
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+    INCLUDE 'mpif.h'
+
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (check) &
+         WRITE(numout,*) "bcast_lgen before bcast Var",Var
+    IF (flag) CALL suspend_timer(timer_mpi)    
+    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,root_prc,MPI_COMM_ORCH,ierr)
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+         WRITE(numout,*) "bcast_lgen after bcast Var",Var
+
+  END SUBROUTINE bcast_lgen
+
+  
+  SUBROUTINE scatter_igen(VarIn, VarOut, dimsize)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(nbp_glo,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_loc,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*nbp_glo) :: VarTmp
+    
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+    
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index_Para:Index_Para+nb-1)=VarIn(nbp_para_begin(rank):nbp_para_end(rank),i)
+          Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+      IF (check) THEN
+         WRITE(numout,*) "scatter_igen VarIn",VarIn
+         WRITE(numout,*) "scatter_igen VarTmp",VarTmp
+      ENDIF
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INT_ORCH,VarOut,nbp_loc*dimsize,   &
+                      MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "scatter_igen VarOut",VarOut
+
+  END SUBROUTINE scatter_igen
+
+  SUBROUTINE scatter_rgen(VarIn, VarOut, dimsize)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(nbp_glo,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_loc,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
+    
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+    
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index_Para:Index_Para+nb-1)=VarIn(nbp_para_begin(rank):nbp_para_end(rank),i)
+          Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+      IF (check) THEN
+         WRITE(numout,*) "scatter_rgen VarIn",VarIn
+         WRITE(numout,*) "scatter_rgen VarTmp",VarTmp
+      ENDIF
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_ORCH,VarOut,nbp_loc*dimsize,   &
+                      MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "scatter_rgen VarOut",VarOut
+
+  END SUBROUTINE scatter_rgen
+  
+  SUBROUTINE scatter_lgen(VarIn, VarOut, dimsize)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(nbp_glo,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_loc,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
+    
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+    
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index_Para:Index_Para+nb-1)=VarIn(nbp_para_begin(rank):nbp_para_end(rank),i)
+          Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+      IF (check) THEN
+         WRITE(numout,*) "scatter_lgen VarIn",VarIn
+         WRITE(numout,*) "scatter_lgen VarTmp",VarTmp
+      ENDIF
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,nbp_loc*dimsize,   &
+                      MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "scatter_lgen VarOut",VarOut
+
+  END SUBROUTINE scatter_lgen  
+
+  SUBROUTINE gather_igen(VarIn, VarOut, dimsize)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(nbp_loc,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_glo,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+    
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*nbp_glo) :: VarTmp
+    
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (is_root_prc) THEN
+      Index_Para=1
+      IF (check) &
+           WRITE(numout,*) "gather_igen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+	Index_Para=Index_Para+nb*dimsize
+      ENDDO
+       IF (check) &
+            WRITE(numout,*) "gather_igen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
+     
+    ENDIF
+    
+    IF (check) &
+         WRITE(numout,*) "gather_igen VarIn=",VarIn    
+    CALL MPI_GATHERV(VarIn,nbp_loc*dimsize,MPI_INT_ORCH,VarTmp,counts,displs,   &
+         MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+
+    IF (check) &
+         WRITE(numout,*) "gather_igen dimsize,VarTmp=",dimsize,VarTmp
+		          
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(nbp_para_begin(rank):nbp_para_end(rank),i)=VarTmp(Index_Para:Index_Para+nb-1)
+	  Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+    ENDIF
+    IF (check) &
+         WRITE(numout,*) "gather_igen VarOut=",VarOut
+    IF (flag) CALL resume_timer(timer_mpi)
+
+  END SUBROUTINE gather_igen  
+
+  SUBROUTINE gather_rgen(VarIn, VarOut, dimsize)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(nbp_loc,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_glo,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
+    
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (is_root_prc) THEN
+      Index_Para=1
+      IF (check) &
+           WRITE(numout,*) "gather_rgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+	Index_Para=Index_Para+nb*dimsize
+      ENDDO
+      IF (check) &
+           WRITE(numout,*) "gather_rgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
+     
+    ENDIF
+    
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarIn=",VarIn    
+    CALL MPI_GATHERV(VarIn,nbp_loc*dimsize,MPI_REAL_ORCH,VarTmp,counts,displs,   &
+                      MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+         WRITE(numout,*) "gather_rgen dimsize,VarTmp=",dimsize,VarTmp
+		          
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(nbp_para_begin(rank):nbp_para_end(rank),i)=VarTmp(Index_Para:Index_Para+nb-1)
+	  Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+    ENDIF
+    IF (check) &
+         WRITE(numout,*) "gather_rgen VarOut=",VarOut
+    IF (flag) CALL resume_timer(timer_mpi)
+
+  END SUBROUTINE gather_rgen  
+
+  SUBROUTINE gather_lgen(VarIn, VarOut, dimsize)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(nbp_loc,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_glo,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*nbp_glo) :: VarTmp
+    
+    INTEGER :: nb,i,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (is_root_prc) THEN
+      Index_Para=1
+      IF (check) &
+           WRITE(numout,*) "gather_lgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+	Index_Para=Index_Para+nb*dimsize
+      ENDDO
+      IF (check) &
+           WRITE(numout,*) "gather_lgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
+    ENDIF
+    
+    IF (check) &
+         WRITE(numout,*) "gather_lgen VarIn=",VarIn    
+    CALL MPI_GATHERV(VarIn,nbp_loc*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
+                      MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+         WRITE(numout,*) "gather_lgen dimsize,VarTmp=",dimsize,VarTmp
+		          
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=nbp_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(nbp_para_begin(rank):nbp_para_end(rank),i)=VarTmp(Index_Para:Index_Para+nb-1)
+	  Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+    ENDIF
+    IF (check) &
+         WRITE(numout,*) "gather_lgen VarOut=",VarOut
+    IF (flag) CALL resume_timer(timer_mpi)
+
+  END SUBROUTINE gather_lgen
+  
+
+  SUBROUTINE scatter2D_igen(VarIn, VarOut, dimsize)
+    USE data_para, iim=>iim_g,jjm=>jjm_g
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(iim*jjm,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1)   :: displs
+    INTEGER,DIMENSION(0:mpi_size-1)   :: counts
+    INTEGER,DIMENSION(dimsize*iim*jjm)   :: VarTmp1
+    INTEGER,DIMENSION(ij_nb,dimsize)     :: VarTmp2
+    
+    INTEGER :: nb,i,ij,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+    
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp1(Index_Para:Index_Para+nb-1)=VarIn(ij_para_begin(rank):ij_para_end(rank),i)
+          Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+      IF (check) THEN
+         WRITE(numout,*) "scatter2D_igen VarIn",VarIn
+         WRITE(numout,*) "scatter2D_igen VarTmp1",VarTmp1
+      ENDIF
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_INT_ORCH,VarTmp2,ij_nb*dimsize,   &
+                      MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+         WRITE(numout,*) "scatter2D_igen VarTmp2",VarTmp2
+   
+    DO i=1,dimsize
+      DO ij=1,ij_nb
+        VarOut(ij+ii_begin-1,i)=VarTmp2(ij,i)
+      ENDDO
+    ENDDO
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "scatter2D_igen VarOut",VarOut
+
+  END SUBROUTINE scatter2D_igen
+  
+  
+  SUBROUTINE scatter2D_rgen(VarIn, VarOut, dimsize)
+    USE data_para, iim=>iim_g,jjm=>jjm_g
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(iim*jjm,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1)   :: displs
+    INTEGER,DIMENSION(0:mpi_size-1)   :: counts
+    REAL,DIMENSION(dimsize*iim*jjm)   :: VarTmp1
+    REAL,DIMENSION(ij_nb,dimsize)     :: VarTmp2
+    REAL,DIMENSION(iim*jj_nb,dimsize) :: VarOut_bis
+    
+    INTEGER :: nb,i,ij,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+    
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp1(Index_Para:Index_Para+nb-1)=VarIn(ij_para_begin(rank):ij_para_end(rank),i)
+          Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+      IF (check) THEN
+         WRITE(numout,*) "scatter2D_rgen VarIn",VarIn
+         WRITE(numout,*) "scatter2D_rgen VarTmp1",VarTmp1
+      ENDIF
+    ENDIF
+    nb=ij_nb*dimsize
+    IF (check) &
+         WRITE(numout,*) "ij_nb*dimsize",ij_nb*dimsize
+      
+    CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_REAL_ORCH,VarTmp2,nb,   &
+                      MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+         WRITE(numout,*) "scatter2D_rgen VarTmp2",VarTmp2
+
+    DO i=1,dimsize
+      DO ij=1,ij_nb
+        VarOut(ij+ii_begin-1,i)=VarTmp2(ij,i)
+      ENDDO
+    ENDDO
+
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "scatter2D_rgen VarOut",VarOut
+
+  END SUBROUTINE scatter2D_rgen
+
+  SUBROUTINE scatter2D_lgen(VarIn, VarOut, dimsize)
+    USE data_para, iim=>iim_g,jjm=>jjm_g
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(iim*jjm,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(iim*jj_nb,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1)   :: displs
+    INTEGER,DIMENSION(0:mpi_size-1)   :: counts
+    LOGICAL,DIMENSION(dimsize*iim*jjm)   :: VarTmp1
+    LOGICAL,DIMENSION(ij_nb,dimsize)     :: VarTmp2
+    
+    INTEGER :: nb,i,ij,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+    
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp1(Index_Para:Index_Para+nb-1)=VarIn(ij_para_begin(rank):ij_para_end(rank),i)
+          Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+      IF (check) THEN
+         WRITE(numout,*) "scatter2D_lgen VarIn",VarIn
+         WRITE(numout,*) "scatter2D_lgen VarTmp1",VarTmp1
+      ENDIF
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp1,counts,displs,MPI_LOGICAL,VarTmp2,ij_nb*dimsize,   &
+                      MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+         WRITE(numout,*) "scatter2D_lgen VarTmp2",VarTmp2
+   
+    DO i=1,dimsize
+      DO ij=1,ij_nb
+        VarOut(ij+ii_begin-1,i)=VarTmp2(ij,i)
+      ENDDO
+    ENDDO
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "scatter2D_lgen VarOut",VarOut
+
+  END SUBROUTINE scatter2D_lgen
+
+
+  SUBROUTINE gather2D_igen(VarIn, VarOut, dimsize)
+    USE data_para, iim=>iim_g,jjm=>jjm_g
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(iim*jj_nb,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(iim*jjm,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(ij_nb,dimsize)   :: VarTmp1
+    INTEGER,DIMENSION(dimsize*iim*jjm) :: VarTmp2
+    
+    INTEGER :: nb,i,ij,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL,PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (is_root_prc) THEN
+      Index_Para=1
+      IF (check) &
+           WRITE(numout,*) "gather2D_igen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+	Index_Para=Index_Para+nb*dimsize
+      ENDDO
+      IF (check) &
+           WRITE(numout,*) "gather2D_igen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
+    ENDIF
+    DO i=1,dimsize
+       DO ij=1,ij_nb
+          VarTmp1(ij,i)=VarIn(ij+ii_begin-1,i)
+       ENDDO
+    ENDDO
+    
+    IF (check) THEN
+       WRITE(numout,*) "gather2D_igen VarIn=",VarIn    
+       WRITE(numout,*) "gather2D_igen VarTmp1=",VarTmp1
+    ENDIF
+    CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_INT_ORCH,VarTmp2,counts,displs,   &
+                     MPI_INT_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+       WRITE(numout,*) "gather2D_igen VarTmp2=",VarTmp2
+		          
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(ij_para_begin(rank):ij_para_end(rank),i)=VarTmp2(Index_Para:Index_Para+nb-1)
+	  Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "gather2D_igen VarOut=",VarOut
+
+  END SUBROUTINE gather2D_igen   
+
+
+  
+  SUBROUTINE gather2D_rgen(VarIn, VarOut, dimsize)
+    USE data_para, iim=>iim_g,jjm=>jjm_g
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(iim*jj_nb,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(iim*jjm,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(ij_nb,dimsize)   :: VarTmp1
+    REAL,DIMENSION(dimsize*iim*jjm) :: VarTmp2
+    
+    INTEGER :: nb,i,ij,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL,PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (is_root_prc) THEN
+      Index_Para=1
+      IF (check) &
+           WRITE(numout,*) "gather2D_rgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+	Index_Para=Index_Para+nb*dimsize
+      ENDDO
+      IF (check) &
+           WRITE(numout,*) "gather2D_rgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
+    ENDIF
+    
+    DO i=1,dimsize
+      DO ij=1,ij_nb
+        VarTmp1(ij,i)=VarIn(ij+ii_begin-1,i)
+      ENDDO
+    ENDDO
+
+    IF (check) THEN
+       WRITE(numout,*) "gather2D_rgen VarIn=",VarIn    
+       WRITE(numout,*) "gather2D_rgen VarTmp1=",VarTmp1
+    ENDIF
+    CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_REAL_ORCH,VarTmp2,counts,displs,   &
+                     MPI_REAL_ORCH,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+       WRITE(numout,*) "gather2D_rgen VarTmp2=",VarTmp2
+
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(ij_para_begin(rank):ij_para_end(rank),i)=VarTmp2(Index_Para:Index_Para+nb-1)
+	  Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "gather2D_rgen VarOut=",VarOut
+
+  END SUBROUTINE gather2D_rgen   
+
+  SUBROUTINE gather2D_lgen(VarIn, VarOut, dimsize)
+    USE data_para, iim=>iim_g,jjm=>jjm_g
+    USE timer
+
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(iim*jj_nb,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(iim*jjm,dimsize) :: VarOut
+  
+    INCLUDE 'mpif.h'
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(ij_nb,dimsize)   :: VarTmp1
+    LOGICAL,DIMENSION(dimsize*iim*jjm) :: VarTmp2
+    
+    INTEGER :: nb,i,ij,index_para,rank
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL,PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (flag) CALL suspend_timer(timer_mpi)
+
+    IF (is_root_prc) THEN
+      Index_Para=1
+      IF (check) &
+           WRITE(numout,*) "gather2D_lgen mpi_size, dimsize, nbp_glo",mpi_size, dimsize, nbp_glo
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        displs(rank)=Index_Para-1
+        counts(rank)=nb*dimsize
+	Index_Para=Index_Para+nb*dimsize
+      ENDDO
+      IF (check) &
+           WRITE(numout,*) "gather2D_lgen nbp_para_nb, displs, counts,Index_Para-1",nbp_para_nb, displs, counts,Index_Para-1
+    ENDIF
+    
+    DO i=1,dimsize
+      DO ij=1,ij_nb
+        VarTmp1(ij,i)=VarIn(ij+ii_begin-1,i)
+      ENDDO
+    ENDDO
+    
+    IF (check) THEN
+       WRITE(numout,*) "gather2D_lgen VarIn=",VarIn    
+       WRITE(numout,*) "gather2D_lgen VarTmp1=",VarTmp1
+    ENDIF
+    CALL MPI_GATHERV(VarTmp1,ij_nb*dimsize,MPI_LOGICAL,VarTmp2,counts,displs,   &
+                     MPI_LOGICAL,root_prc, MPI_COMM_ORCH,ierr)
+    IF (check) &
+       WRITE(numout,*) "gather2D_lgen VarTmp2=",VarTmp2
+		          
+    IF (is_root_prc) THEN
+      Index_Para=1
+      DO rank=0,mpi_size-1
+        nb=ij_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(ij_para_begin(rank):ij_para_end(rank),i)=VarTmp2(Index_Para:Index_Para+nb-1)
+	  Index_Para=Index_Para+nb
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "gather2D_lgen VarOut=",VarOut
+
+  END SUBROUTINE gather2D_lgen   
+
+  SUBROUTINE reduce_sum_igen(VarIn,VarOut,nb)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+    
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    
+    INCLUDE 'mpif.h'
+
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (check) &
+       WRITE(numout,*) "reduce_sum_igen VarIn",VarIn
+    IF (flag) CALL suspend_timer(timer_mpi)
+   
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INT_ORCH,MPI_SUM,root_prc,MPI_COMM_ORCH,ierr)
+            
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "reduce_sum_igen VarOut",VarOut
+
+  END SUBROUTINE reduce_sum_igen
+  
+  SUBROUTINE reduce_sum_rgen(VarIn,VarOut,nb)
+    USE data_para
+    USE timer
+
+    IMPLICIT NONE
+    
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+
+    INCLUDE 'mpif.h'
+    
+    INTEGER :: ierr
+    LOGICAL :: flag=.FALSE.
+    LOGICAL, PARAMETER :: check=.FALSE.
+
+    IF (timer_state(timer_mpi)==running) THEN
+      flag=.TRUE.
+    ELSE
+      flag=.FALSE.
+    ENDIF
+    
+    IF (check) &
+       WRITE(numout,*) "reduce_sum_rgen VarIn",VarIn
+    IF (flag) CALL suspend_timer(timer_mpi)
+   
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_ORCH,MPI_SUM,root_prc,MPI_COMM_ORCH,ierr)
+        
+    IF (flag) CALL resume_timer(timer_mpi)
+    IF (check) &
+       WRITE(numout,*) "reduce_sum_rgen VarOut",VarOut
+
+  END SUBROUTINE reduce_sum_rgen
+
+  subroutine stopit
+    USE ioipsl
+    call MPI_FINALIZE
+
+    CALL ipslerr (3,'transfert_para : gather', &
+         &          'A gather function was called with a VarIn',&
+         &          ' which size is only one.', &
+         &          '(must be strickly greater than one )')
+  end subroutine stopit
+#endif
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/write_field.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/write_field.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/write_field.f90	(revision 55)
@@ -0,0 +1,9 @@
+! Yann Meurdesoif module for sequentiel tests.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/write_field.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
+!-
+
+MODULE Write_Field
+  USE Orch_Write_Field
+END MODULE Write_Field
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/write_field_p.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/write_field_p.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parallel/write_field_p.f90	(revision 55)
@@ -0,0 +1,9 @@
+! Yann Meurdesoif module for parallel tests.
+
+!-
+!- $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parallel/write_field_p.f90,v 1.2 2007/06/12 08:04:26 ssipsl Exp $
+!-
+
+MODULE Write_field_p
+  USE Orch_Write_Field_p
+END MODULE Write_field_p
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/AA_make
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/AA_make	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/AA_make	(revision 55)
@@ -0,0 +1,76 @@
+#-
+#- $Id$
+#-
+IOIPSL_LIB = $(LIBDIR)/libioipsl.a
+SXIOIPSL_LIB = $(IOIPSL_LIB)
+#-Q- sxnec SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
+#-Q- sx6nec SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
+#-Q- eshpux SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
+#-Q- sx8brodie SXIOIPSL_LIB = $(LIBDIR)/libsxioipsl.a
+#-
+PARALLEL_LIB = $(LIBDIR)/libparallel.a
+SXPARALLEL_LIB = $(PARALLEL_LIB)
+#-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-
+MODS1 = constantes.f90 \
+        constantes_veg.f90 \
+        constantes_soil.f90 \
+        constantes_co2.f90 
+OBJSMODS1 = $(MODS1:.f90=.o)
+#-
+.PRECIOUS : $(MODEL_LIB)
+#-Q- sxnec  .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
+#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
+#-
+all:
+	$(M_K) libioipsl
+	$(M_K) libparallel
+	$(M_K) m_all
+	@echo parameter is OK
+
+m_all: $(MODEL_LIB)($(OBJSMODS1))
+
+libioipsl:
+	(cd ../../IOIPSL/src; $(M_K) -f Makefile)
+
+libparallel:
+	(cd ../src_parallel; $(M_K) -f Makefile)
+
+$(MODEL_LIB)(%.o): %.f90
+	$(F_C) $(F_O) $*.f90
+	$(A_C) $(MODEL_LIB) $*.o
+#-Q- sxnec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sxnec 	mv $*.mod $(MODDIR)
+#-Q- sx6nec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx6nec 	mv $*.mod $(MODDIR)
+#-Q- eshpux 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- eshpux 	mv $*.mod $(MODDIR)
+#-Q- sx8mercure 	mv $*.mod $(MODDIR)
+#-Q- sx9mercure 	mv $*.mod $(MODDIR)
+#-Q- sx8brodie 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx8brodie 	mv $*.mod $(MODDIR)
+#-Q- solaris 	mv $*.mod $(MODDIR)
+	$(RM) $*.o
+
+config:
+	$(BINDIR)/Fparser -name PARAMETERS  $(MODS1)
+	echo 'Configuration of PARAMETERS done'
+ 
+clean:
+	$(RM) $(MODEL_LIB)
+ 
+$(MODEL_LIB)(constantes_co2.o): \
+  $(MODEL_LIB)(constantes_veg.o)
+$(MODEL_LIB)(constantes_veg.o): \
+  $(MODEL_LIB)(constantes_soil.o)
+$(MODEL_LIB)(constantes_soil.o): \
+  $(MODEL_LIB)(constantes.o)
+$(MODEL_LIB)(constantes.o): \
+  $(PARALLEL_LIB) \
+  $(IOIPSL_LIB)
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/AA_make.ldef
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/AA_make.ldef	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/AA_make.ldef	(revision 55)
@@ -0,0 +1,18 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a PARAMETER
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+MODEL_LIB = $(LIBDIR)/libparameters.a
+SXMODEL_LIB = $(MODEL_LIB)
+#-Q- sxnec  SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxparameters.a
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes.f90	(revision 55)
@@ -0,0 +1,85 @@
+!$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes.f90,v 1.16 2007/08/01 15:19:05 ssipsl Exp $
+!IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!-
+MODULE constantes
+!!--------------------------------------------------------------------
+!! "constantes" module contains some public technical constants
+!!--------------------------------------------------------------------
+  USE defprec
+  USE parallel
+!-
+  IMPLICIT NONE
+!-
+! To set for more printing
+  LOGICAL,SAVE :: long_print = .FALSE.
+!-
+! One of the most frequent problems is a temperature out of range
+! we provide here a way to catch that in the calling procedure. (JP)
+  LOGICAL,PARAMETER :: diag_qsat = .TRUE.
+!-
+! Selects the type of output for the model.
+! Value is read from run.def in intersurf_history.
+  LOGICAL           :: almaoutput
+!-
+! One day in seconds
+  REAL(r_std),SAVE :: one_day
+! One year in seconds
+  REAL(r_std),SAVE :: one_year
+! Earth radius ~= Equatorial radius
+! The Earth's equatorial radius a, or semi-major axis, is the distance from its center to the equator and equals 6,378.1370 km.
+! The equatorial radius is often used to compare Earth with other planets.
+  REAL(r_std), PARAMETER                          :: R_Earth = 6378000.
+!The meridional mean is well approximated by the semicubic mean of the two axe yielding 6367.4491 km
+! or less accurately by the quadratic mean of the two axes about 6,367.454 km
+! or even just the mean of the two axes about 6,367.445 km.
+!-
+! No comment
+  REAL(r_std),PARAMETER :: pi=3.141592653589793238
+!-
+! 0 degre Celsius in degre Kelvin
+  REAL(r_std),PARAMETER :: tp_00=273.15
+!-
+! Specific value if no restart value
+  REAL(r_std),SAVE :: val_exp = 999999.
+!-
+! Epsilon to detect a near zero floating point
+  REAL(r_std),PARAMETER :: min_sechiba = 1.E-8_r_std
+! The undef value used in SECHIBA
+  REAL(r_std),PARAMETER :: undef_sechiba = 1.E+20_r_std
+!-
+! Numerical constant set to 0
+  REAL(r_std),PARAMETER :: zero = 0._r_std
+! Numerical constant set to 1/2
+  REAL(r_std),PARAMETER :: undemi = 0.5_r_std
+! Numerical constant set to 1
+  REAL(r_std),PARAMETER :: un = 1._r_std
+! Numerical constant set to -1
+  REAL(r_std),PARAMETER :: moins_un = -1._r_std
+! Numerical constant set to 2
+  REAL(r_std),PARAMETER :: deux = 2._r_std
+! Numerical constant set to 3
+  REAL(r_std),PARAMETER :: trois = 3._r_std
+! Numerical constant set to 4
+  REAL(r_std),PARAMETER :: quatre = 4._r_std
+! Numerical constant set to 5
+  REAL(r_std),PARAMETER :: cinq = 5._r_std
+! Numerical constant set to 6
+  REAL(r_std),PARAMETER :: six = 6._r_std
+! Numerical constant set to 8
+  REAL(r_std),PARAMETER :: huit = 8._r_std
+! Numerical constant set to 1000
+  REAL(r_std),PARAMETER :: mille = 1000._r_std
+!-
+  TYPE control_type
+    LOGICAL :: river_routing
+    LOGICAL :: hydrol_cwrr
+    LOGICAL :: ok_sechiba
+    LOGICAL :: ok_co2
+    LOGICAL :: ok_stomate
+    LOGICAL :: ok_dgvm
+    LOGICAL :: stomate_watchout
+    LOGICAL :: ok_pheno
+  END TYPE control_type
+!--------------------
+END MODULE constantes
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_co2.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_co2.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_co2.f90	(revision 55)
@@ -0,0 +1,81 @@
+!$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes_co2.f90,v 1.10 2007/05/28 15:28:05 ssipsl Exp $
+!IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!-
+MODULE constantes_co2
+!!--------------------------------------------------------------------
+!! "constantes_co2" module contains some public technical constants
+!!--------------------------------------------------------------------
+  USE constantes_veg
+!-
+  IMPLICIT NONE
+!-
+! indices for assimilation parameters
+!-
+  INTEGER(i_std),PARAMETER :: itmin = 1
+  INTEGER(i_std),PARAMETER :: itopt = 2
+  INTEGER(i_std),PARAMETER :: itmax = 3
+  INTEGER(i_std),PARAMETER :: ivcmax = 4
+  INTEGER(i_std),PARAMETER :: ivjmax = 5
+  INTEGER(i_std),PARAMETER :: npco2 = 5
+!-
+!!
+!! The following tables of parameters for SECHIBA
+!! are in the following order :
+!!
+!!    1 - Bare soil
+!!    2 - tropical  broad-leaved evergreen
+!!    3 - tropical  broad-leaved raingreen
+!!    4 - temperate needleleaf   evergreen
+!!    5 - temperate broad-leaved evergreen
+!!    6 - temperate broad-leaved summergreen
+!!    7 - boreal    needleleaf   evergreen
+!!    8 - boreal    broad-leaved summergreen
+!!    9 - boreal    needleleaf   summergreen
+!!   10 -           C3           grass
+!!   11 -           C4           grass
+!!   12 -           C3           agriculture
+!!   13 -           C4           agriculture
+!!
+! flag for C4 vegetation types
+  LOGICAL,DIMENSION(nvm),SAVE :: &
+ &  is_c4 = (/.false.,.false.,.false.,.false.,.false.,.false., &
+ &            .false.,.false.,.false.,.false.,.true.,.false.,.true. /)
+! Slope of the gs/A relation (Ball & al.)
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  gsslope = (/0., 9., 9., 9., 9., 9., 9., 9., 9., 9., 3., 9., 3./)
+! intercept of the gs/A relation (Ball & al.)
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  gsoffset = (/0.0,  0.01, 0.01, 0.01, 0.01, 0.01, &
+ &               0.01, 0.01, 0.01, 0.01, 0.03, 0.01, 0.03/)
+! values used for vcmax when STOMATE is not activated
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  vcmax_fix = (/  0., 40., 50., 30., 35., 40., &
+ &                 30., 40., 35., 60., 60., 70., 70. /)
+! values used for vjmax when STOMATE is not activated
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  vjmax_fix = (/ 0., 80., 100., 60., 70., 80., &
+ &                 60., 80., 70., 120., 120., 140., 140. /)
+! values used for photosynthesis tmin when STOMATE is not activated
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  co2_tmin_fix = (/ 0.,  2.,  2., -4., -3., -2., &
+ &                   -4., -4., -4., -5.,  6., -5.,  6. /)
+! values used for photosynthesis topt when STOMATE is not activated
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  co2_topt_fix = (/  0.,  27.5, 27.5, 17.5, 25.,  20.,  &
+ &                    17.5, 17.5, 17.5, 20.,  32.5, 20.,  32.5 /)
+! values used for photosynthesis tmax when STOMATE is not activated
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  co2_tmax_fix = (/ 0., 55., 55., 38., 48., 38., &
+ &                   38., 38., 38., 45., 55., 45., 55. /)
+! extinction coefficient of the Monsi&Seaki relationship (1953)
+  REAL(r_std),DIMENSION(nvm),SAVE :: &
+ &  ext_coef = (/.5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5, .5/)
+! NV080800 Name of STOMATE forcing file
+  CHARACTER(LEN=100) :: stomate_forcing_name='NONE'
+! NV080800 Name of soil forcing file
+  CHARACTER(LEN=100) :: stomate_Cforcing_name='NONE'
+!-
+  INTEGER(i_std),SAVE :: forcing_id
+!------------------------
+END MODULE constantes_co2
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_soil.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_soil.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_soil.f90	(revision 55)
@@ -0,0 +1,153 @@
+!$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes_soil.f90,v 1.11 2010/04/06 14:38:48 ssipsl Exp $
+!IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!-
+MODULE constantes_soil
+!!--------------------------------------------------------------------
+!! "constantes_soil" module contains public data for the soils
+!!--------------------------------------------------------------------
+  USE constantes
+!-
+  IMPLICIT NONE
+!-
+! Dimensioning parameters
+!-
+! Number of soil level
+  INTEGER(i_std),PARAMETER :: ngrnd=7
+! Number of diagnostic levels in the soil
+  INTEGER(i_std),PARAMETER :: nbdl=11
+!MM : if you want to compare hydrology variables with old TAG 1.6 and lower, 
+!     you must set the Number of diagnostic levels in the soil to 6 :
+!  INTEGER(i_std),PARAMETER :: nbdl=6
+! Number of levels in CWRR
+  INTEGER(i_std),PARAMETER :: nslm=11
+! Number of soil types
+  INTEGER(i_std),PARAMETER :: nstm=3
+!-
+!- Parameters for soil thermodynamics
+!-
+! Average Thermal Conductivity of soils
+  REAL(r_std),PARAMETER :: so_cond = 1.5396
+! Average Heat capacity of soils
+  REAL(r_std),PARAMETER :: so_capa = 2.0514e+6
+!-
+! Values taken from : PIELKE,'MESOSCALE METEOROLOGICAL MODELING',P.384
+! Dry soil heat capacity was decreased and conductivity increased.
+!-
+! Dry soil Heat capacity of soils
+!*REAL(r_std),PARAMETER :: so_capa_dry = 1.35e+6
+  REAL(r_std),PARAMETER :: so_capa_dry = 1.80e+6
+! Dry soil Thermal Conductivity of soils
+!*REAL(r_std),PARAMETER :: so_cond_dry = 0.28
+  REAL(r_std),PARAMETER :: so_cond_dry = 0.40
+!-
+! Wet soil Heat capacity of soils
+  REAL(r_std),PARAMETER :: so_capa_wet = 3.03e+6
+! Wet soil Thermal Conductivity of soils
+  REAL(r_std),PARAMETER :: so_cond_wet = 1.89
+!-
+! Thermal Conductivity of snow
+  REAL(r_std),PARAMETER :: sn_cond = 0.3
+! Snow density for the soil thermodynamics
+  REAL(r_std),PARAMETER :: sn_dens = 330.0
+! Heat capacity for snow
+  REAL(r_std),PARAMETER :: sn_capa = 2100.0_r_std*sn_dens
+!-
+! Constantes from the Choisnel hydrology
+!-
+! Wilting point (Has a numerical role for the moment)
+  REAL(r_std),PARAMETER :: qwilt = 5.0
+! Total depth of soil reservoir (for hydrolc)
+  REAL(r_std),SAVE :: dpu_cste=2.0_r_std
+! The minimal size we allow for the upper reservoir (m)
+  REAL(r_std),PARAMETER :: min_resdis = 2.e-5
+! Diffusion constant for the slow regime
+! (This is for the diffusion between reservoirs)
+  REAL(r_std),PARAMETER :: min_drain = 0.001
+! Diffusion constant for the fast regime
+  REAL(r_std),PARAMETER :: max_drain = 0.1
+! The exponential in the diffusion law
+  REAL(r_std),PARAMETER :: exp_drain = 1.5
+! Transforms leaf area index into size of interception reservoir
+  REAL(r_std),SAVE      :: qsintcst = 0.1
+! Maximum quantity of water (Kg/M3)
+  REAL(r_std),PARAMETER :: mx_eau_eau = 150.
+!-
+! Constant in the computation of resistance for bare  soil evaporation
+  REAL(r_std),PARAMETER :: rsol_cste = 33.E3
+! Scaling depth for litter humidity (m)
+!SZ changed this according to SP from 0.03 to 0.08, 080806
+  REAL(r_std),PARAMETER :: hcrit_litter=0.08_r_std
+!-
+! Parameters for soil type distribution
+!-
+! Default soil texture distribution in the following order :
+!    sand, loam and clay
+  REAL(r_std),DIMENSION(nstm),SAVE :: soiltype_default = &
+ & (/ 0.0, 1.0, 0.0 /)
+!-
+! Parameters specific for the CWRR hydrology.
+!-
+! Van genuchten coefficient n
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: nvan = &
+ & (/ 1.89_r_std, 1.56_r_std, 1.31_r_std /)
+!!$! Van genuchten coefficient a (cm^{-1})
+!!$  REAL(r_std),PARAMETER,DIMENSION(nstm) :: avan = &
+!!$ & (/ 0.036_r_std, 0.036_r_std, 0.036_r_std /)
+!TdO
+! Van genuchten coefficient a (mm^{-1})
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: avan = &
+  & (/ 0.0075_r_std, 0.0036_r_std, 0.0019_r_std /) 
+! CWRR linearisation
+  INTEGER(i_std),PARAMETER :: imin = 1
+! number of interval for CWRR
+  INTEGER(i_std),PARAMETER :: nbint = 100
+! number of points for CWRR
+  INTEGER(i_std),PARAMETER :: imax = nbint+1
+! Residual soil water content
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: mcr = &
+ & (/ 0.065_r_std, 0.078_r_std, 0.095_r_std /)
+! Saturated soil water content
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: mcs = &
+ & (/ 0.41_r_std, 0.43_r_std, 0.41_r_std /)
+! Total depth of soil reservoir (m)
+  REAL(r_std),SAVE,DIMENSION(nstm) :: dpu = &
+ & (/ 2.0_r_std, 2.0_r_std, 2.0_r_std /)
+  ! dpu must be constant over the different soil types
+! Hydraulic conductivity Saturation (mm/d)
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: ks = &
+ & (/ 1060.8_r_std, 249.6_r_std, 62.4_r_std /)
+! Soil moisture above which transpir is max
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: pcent = &
+ & (/ 0.5_r_std, 0.5_r_std, 0.5_r_std /)
+! Max value of the permeability coeff at the bottom of the soil
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: free_drain_max = &
+ & (/ 1.0_r_std, 1.0_r_std, 1.0_r_std /)
+! Volumetric water content field capacity
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: mcf = &
+ & (/ 0.32_r_std, 0.32_r_std, 0.32_r_std /)
+! Volumetric water content Wilting pt
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: mcw = &
+ & (/ 0.10_r_std, 0.10_r_std, 0.10_r_std /)
+! Vol. wat. cont. above which albedo is cst
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: mc_awet = &
+ & (/ 0.25_r_std, 0.25_r_std, 0.25_r_std /)
+! Vol. wat. cont. below which albedo is cst
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: mc_adry = &
+ & (/ 0.1_r_std, 0.1_r_std, 0.1_r_std /)
+! Matrix potential at saturation (mm)
+  REAL(r_std),PARAMETER,DIMENSION(nstm) :: psis = &
+ & (/ -300.0_r_std, -300.0_r_std, -300.0_r_std /)
+! Time weighting for discretisation
+  REAL(r_std),PARAMETER :: w_time = 1.0_r_std
+!-
+! Diagnostic variables
+!-
+! The lower limit of the layer on which soil moisture (relative)
+! and temperature are going to be diagnosed.
+! These variables are made for transfering the information
+! to the biogeophyical processes modelled in STOMATE.
+!-
+  REAL(r_std),DIMENSION(nbdl),SAVE :: diaglev 
+!-------------------------
+END MODULE constantes_soil
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_veg.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_veg.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_parameters/constantes_veg.f90	(revision 55)
@@ -0,0 +1,941 @@
+!$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_parameters/constantes_veg.f90,v 1.32 2008/04/10 16:09:40 ssipsl Exp $
+!IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!-
+MODULE constantes_veg
+!!--------------------------------------------------------------------
+!! "constantes_soil" module contains public physical constantes
+!! and public tools functions like    qsat, dev_qsat
+!!--------------------------------------------------------------------
+  USE IOIPSL
+  USE constantes_soil
+!-
+  IMPLICIT NONE
+!-
+  LOGICAL,SAVE :: l_qsat_first=.TRUE.
+!-
+! Flags that (de)activate parts of the model
+  TYPE(control_type),SAVE :: control
+!-
+! Number of vegetation types
+  INTEGER(i_std),PARAMETER :: nvm=13
+! Number of other surface types: land ice (lakes,cities, ...)
+  INTEGER(i_std),PARAMETER :: nnobio=1
+!-
+! Index for land ice (see nnobio)
+  INTEGER(i_std),PARAMETER :: iice = 1
+! The maximum mass (kg/m^2) of a glacier.
+  REAL(r_std),PARAMETER :: maxmass_glacier = 3000.
+!-
+! Minimal fraction of mesh a vegetation type can occupy
+  REAL(r_std),PARAMETER :: min_vegfrac=0.001
+!-
+! Constant in the computation of surface resistance
+  REAL(r_std),PARAMETER :: defc_plus=23.E-3
+! Constant in the computation of surface resistance
+  REAL(r_std),PARAMETER :: defc_mult=1.5
+!-
+! Limit of air temperature for snow
+  REAL(r_std),PARAMETER :: tsnow=273.
+!-
+! Sets the amount above which only sublimation occures [Kg/m^2]
+  REAL(r_std),PARAMETER :: snowcri=1.5
+! Critical value for computation of snow albedo [Kg/m^2]
+  REAL(r_std),PARAMETER :: snowcri_alb=10.
+! Lower limit of snow amount
+  REAL(r_std),PARAMETER :: sneige=snowcri/1000._r_std
+! Latent heat of sublimation
+  REAL(r_std),PARAMETER :: chalsu0 = 2.8345E06
+! Latent heat of evaporation
+  REAL(r_std),PARAMETER :: chalev0 = 2.5008E06
+! Latent heat of evaporation 2 (?)
+  REAL(r_std),PARAMETER :: chalev1 = 2.5008E06
+! Latent heat of fusion
+  REAL(r_std),PARAMETER :: chalfu0 = chalsu0-chalev0
+!-
+! Stefan-Boltzman constant
+  REAL(r_std),PARAMETER :: c_stefan = 5.6697E-8
+! Specific heat of air
+  REAL(r_std),PARAMETER :: cp_air = 1004.675
+! Constante molere
+  REAL(r_std),PARAMETER :: cte_molr = 287.05
+! Kappa
+  REAL(r_std),PARAMETER :: kappa = cte_molr/cp_air
+! in -- Kg/mole
+  REAL(r_std),PARAMETER :: msmlr_air = 28.964E-03
+! in -- Kg/mole
+  REAL(r_std),PARAMETER :: msmlr_h2o = 18.02E-03
+!
+  REAL(r_std),PARAMETER :: cp_h2o = &
+ & cp_air*(4._r_std*msmlr_air)/( 3.5_r_std*msmlr_h2o)
+!
+  REAL(r_std),PARAMETER :: cte_molr_h2o = cte_molr/4._r_std
+!
+  REAL(r_std),PARAMETER :: retv = msmlr_air/msmlr_h2o-1._r_std
+!
+  REAL(r_std),PARAMETER :: rvtmp2 = cp_h2o/cp_air-1._r_std
+!
+  REAL(r_std),PARAMETER :: cepdu2 = (0.1_r_std) **2
+! Van Karmann Constante
+  REAL(r_std),PARAMETER :: ct_karman = 0.35_r_std
+! g acceleration
+  REAL(r_std),PARAMETER :: cte_grav = 9.80665_r_std
+! Constantes of the Louis scheme
+  REAL(r_std),PARAMETER :: cb = 5._r_std
+  REAL(r_std),PARAMETER :: cc = 5._r_std
+  REAL(r_std),PARAMETER :: cd = 5._r_std
+! The minimum wind
+  REAL(r_std),PARAMETER :: min_wind = 0.1
+! Transform pascal into hectopascal
+  REAL(r_std),PARAMETER :: pa_par_hpa = 100._r_std
+! Time constant of the albedo decay of snow
+  REAL(r_std),PARAMETER :: tcst_snowa = 5._r_std
+! Maximum period of snow aging
+  REAL(r_std),PARAMETER :: max_snow_age = 50._r_std
+! Transformation time constant for snow (m)
+  REAL(r_std),PARAMETER :: snow_trans = 0.3_r_std
+! bare soil roughness length (m)
+  REAL(r_std),PARAMETER :: z0_bare = 0.01
+! ice roughness length (m)
+  REAL(r_std),PARAMETER :: z0_ice = 0.001
+!-
+! allow agricultural PFTs
+  LOGICAL,SAVE :: agriculture = .TRUE.
+!!
+!! The following tables of parameters for SECHIBA
+!! are in the following order :
+!!
+!!    1 - Bare soil
+!!    2 - tropical  broad-leaved evergreen
+!!    3 - tropical  broad-leaved raingreen
+!!    4 - temperate needleleaf   evergreen
+!!    5 - temperate broad-leaved evergreen
+!!    6 - temperate broad-leaved summergreen
+!!    7 - boreal    needleleaf   evergreen
+!!    8 - boreal    broad-leaved summergreen
+!!    9 - boreal    needleleaf   summergreen
+!!   10 -           C3           grass
+!!   11 -           C4           grass
+!!   12 -           C3           agriculture
+!!   13 -           C4           agriculture
+!!
+! Value for veget_ori for tests in 0-dim simulations
+  REAL(r_std),DIMENSION(nvm),SAVE :: veget_ori_fixed_test_1 = &
+ & (/ 0.2, 0.0, 0.0, 0.0, 0.0, &
+ &    0.0, 0.0, 0.0, 0.0, 0.8, &
+ &    0.0, 0.0, 0.0 /)
+! Value for frac_nobio for tests in 0-dim simulations
+! laisser ca tant qu'il n'y a que de la glace (pas de lacs)
+  REAL(r_std),SAVE :: frac_nobio_fixed_test_1 = 0.0
+! REAL(r_std), DIMENSION(nnobio),SAVE :: frac_nobio_fixed_test_1=(/0.0/)
+!-
+! laimax for maximum lai see also type of lai interpolation
+  REAL(r_std),DIMENSION(nvm),SAVE :: llaimax = &
+ & (/ 0., 8., 8., 4., 4.5, 4.5, 4., 4.5, 4., 2., 2., 2., 2./)
+! laimin for minimum lai see also type of lai interpolation
+  REAL(r_std),DIMENSION(nvm),SAVE :: llaimin = &
+ & (/ 0., 8., 0., 4., 4.5, 0., 4., 0., 0., 0., 0., 0., 0./)
+!-
+! prescribed height of vegetation.
+! Value for height_presc : one for each vegetation type
+  REAL(r_std),DIMENSION(nvm),SAVE :: height_presc = &
+ & (/ 0.,30.,30.,20.,20.,20.,15.,15.,15.,.5,.6,1.,1./)
+!-
+! Structural resistance.
+! Value for rstruct_const : one for each vegetation type
+  REAL(r_std),DIMENSION(nvm),SAVE :: rstruct_const = &
+ & (/ 0.0, 25.0, 25.0, 25.0, 25.0, 25.0, 25.0,&
+ &   25.0, 25.0, 2.5, 2.0, 2.0, 2.0 /)
+!-
+! A vegetation dependent constant used in the calculation
+! of the surface resistance.
+! Value for kzero one for each vegetation type
+  REAL(r_std),DIMENSION(nvm),SAVE :: kzero = &
+ & (/0.0, 12.E-5, 12.E-5, 12.e-5, 12.e-5, 25.e-5, 12.e-5,&
+       & 25.e-5, 25.e-5, 30.e-5, 30.e-5, 30.e-5, 30.e-5 /)
+!-
+! Maximum field capacity for each of the vegetations (Temporary).
+! Value of wmax_veg : max quantity of water :
+! one for each vegetation type en Kg/M3
+  REAL(r_std),DIMENSION(nvm),SAVE :: wmax_veg = &
+ & (/ 150., 150., 150., 150., 150., 150., 150.,&
+ &    150., 150., 150., 150., 150., 150. /)
+!-
+! Root profile description for the different vegetation types.
+! These are the factor in the exponential which gets
+! the root density as a function of depth
+  REAL(r_std),DIMENSION(nvm), SAVE :: humcste = &
+ & (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4./)
+!-
+! Type of behaviour of the LAI evolution algorithm
+! for each vegetation type.
+! Value of type_of_lai, one for each vegetation type : mean or interp
+!!$  CHARACTER(len=5),DIMENSION(nvm),SAVE :: type_of_lai = &
+!!$ & (/ 'mean ', 'mean ', 'inter', 'mean ', 'mean ', &
+!!$ &    'inter', 'mean ', 'inter', 'inter', 'inter', &
+!!$ &    'inter', 'inter', 'inter' /)
+! Test Nathalie : Even Sempervirens vegetation is allowed to have a small seasonal cycle.
+  CHARACTER(len=5),DIMENSION(nvm),SAVE :: type_of_lai = &
+ & (/ 'inter', 'inter', 'inter', 'inter', 'inter', &
+ &    'inter', 'inter', 'inter', 'inter', 'inter', &
+ &    'inter', 'inter', 'inter' /)
+!-
+! Is the vegetation type a tree ?
+  LOGICAL, DIMENSION(nvm),SAVE :: is_tree = &
+ & (/ .FALSE., .TRUE.,  .TRUE., .TRUE., .TRUE.,  &
+ &    .TRUE.,  .TRUE.,  .TRUE., .TRUE., .FALSE., &
+ &    .FALSE., .FALSE., .FALSE. /)
+!-
+! Initial snow albedo value for each vegetation type
+! as it will be used in condveg_snow
+! Values are from the Thesis of S. Chalita (1992)
+!  REAL(r_std),DIMENSION(nvm),SAVE :: snowa_ini = &
+! & (/ 0.55, 0.,   0.,   0.14, 0.15, &
+! &    0.15, 0.14, 0.15, 0.14, 0.18, &
+! &    0.18, 0.18, 0.18 /)
+! Nathalie - Decembre 2006 - on limite les albedos de sol nu en presence de neige, ainsi que ceux de la vegetation
+! les valeurs choisies sont proches de celles que nous avions prises dans LMD5.3 avec Delphine Texier
+  REAL(r_std),DIMENSION(nvm),SAVE :: snowa_ini = &
+ & (/ 0.35, 0.,   0.,   0.14, 0.14, &
+ &    0.14, 0.14, 0.14, 0.14, 0.18, &
+ &    0.18, 0.18, 0.18 /)
+! Decay rate of snow albedo value for each vegetation type
+! as it will be used in condveg_snow
+! Values are from the Thesis of S. Chalita (1992)
+!  REAL(r_std),DIMENSION(nvm),SAVE :: snowa_dec = &
+! & (/ 0.30, 0.,   0.,   0.06, 0.14, &
+! &    0.14, 0.06, 0.25, 0.06, 0.63, &
+! &    0.63, 0.63, 0.63 /)
+  ! Nathalie - Decembre 2006 - on limite les albedos de sol nu en presence de neige, ainsi que ceux de la vegetation
+  ! les valeurs choisies sont proches de celles que nous avions prises dans LMD5.3 avec Delphine Texier
+!-
+  REAL(r_std),DIMENSION(nvm),SAVE :: snowa_dec = &
+ & (/ 0.45, 0.,   0.,   0.06, 0.06, &
+ &    0.11, 0.06, 0.11, 0.11, 0.52, &
+ &    0.52, 0.52, 0.52 /)
+
+! leaf albedo of vegetation type, VIS+NIR
+  REAL(r_std),DIMENSION(nvm*2),SAVE :: alb_leaf = &
+ & (/ .00, .04, .06, .06, .06, &
+ &    .06, .06, .06, .06, .10, &
+ &    .10, .10, .10, &
+ &    .00, .20, .22, .22, .22, &
+ &    .22, .22, .22, .22, .30, &
+ &    .30, .30, .30   /)
+!-
+! Table which contains the correlation between the soil types
+! and vegetation type. Two modes exist :
+!  1) pref_soil_veg = 0 then we have an equidistribution
+!     of vegetation on soil types
+!  2) Else for each pft the prefered soil type is given :
+!     1=sand, 2=loan, 3=clay
+! The variable is initialized in slowproc.
+  INTEGER(i_std),DIMENSION(nvm,nstm) ::  pref_soil_veg
+!-
+! albedo of dead leaves, VIS+NIR
+  REAL(r_std),DIMENSION(2),SAVE :: alb_deadleaf = (/ .12, .35/)
+! albedo of ice, VIS+NIR
+  REAL(r_std),DIMENSION(2),SAVE :: alb_ice = (/ .60, .20/)
+!-
+! Is veget_ori array stored in restart file
+  LOGICAL,PARAMETER :: ldveget_ori_on_restart = .TRUE.
+!-
+! Set to .TRUE. if you want q_cdrag coming from GCM
+  LOGICAL,SAVE :: ldq_cdrag_from_gcm = .FALSE.
+!-
+! Constant in the computation of surface resistance
+  REAL(r_std),PARAMETER :: rayt_cste = 125.
+!-
+! Size of local array to keep saturated humidity
+! at each temperature level
+  INTEGER(i_std),PARAMETER :: max_temp=370
+! Minimum temperature for saturated humidity
+  INTEGER(i_std),PARAMETER :: min_temp=100
+! Local array to keep saturated humidity at each temperature level
+  REAL(r_std),DIMENSION(max_temp),SAVE :: qsfrict
+!-
+!===
+CONTAINS
+!===
+SUBROUTINE qsatcalc (kjpindex,temp_in,pres_in,qsat_out)
+!---------------------------------------------------------------------
+    ! input value
+! Domain size
+  INTEGER(i_std),INTENT(in) :: kjpindex
+! Temperature in degre Kelvin
+  REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: temp_in
+! Pressure
+  REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: pres_in
+    ! output value
+! Result
+  REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: qsat_out
+!-
+    ! local variables
+  INTEGER(i_std), DIMENSION(kjpindex)       :: jt
+  INTEGER(i_std)                            :: ji
+  REAL(r_std),DIMENSION(kjpindex)     :: zz_a, zz_b, zz_f
+  INTEGER(i_std)                     :: nbad
+  INTEGER(i_std),DIMENSION(1)        :: lo
+!---------------------------------------------------------------------
+  IF (l_qsat_first) THEN
+    CALL qsfrict_init
+    l_qsat_first = .FALSE.
+  ENDIF
+!-
+! 1. computes qsat interpolation into two successive temperature
+!-
+  jt = INT(temp_in(:))
+!-
+  nbad = COUNT(jt(:) >= max_temp-1)
+  IF (nbad > 0) THEN
+    WRITE(numout,*) ' qsatcalc: temperature too high at ', &
+ &    nbad, ' points.'
+    IF (.NOT.diag_qsat) THEN
+        CALL ipslerr(2,'qsatcalc','diffuco', '', &
+ &                     'temperature incorect.')
+    ELSE
+      lo = MAXLOC(temp_in(:))
+      WRITE(numout,*) &
+ &     'Maximum temperature ( ',MAXVAL(temp_in),') found at ',lo(1)
+      WHERE (jt(:) >= max_temp-1)   jt(:) = max_temp-1
+    ENDIF
+  ENDIF
+!-
+  nbad = COUNT(jt(:) <= min_temp)
+  IF (nbad > 0) THEN
+    WRITE(numout,*) ' qsatcalc: temperature too low at ', &
+ &    nbad, ' points.'
+    IF (.NOT.diag_qsat) THEN
+      CALL ipslerr(2,'qsatcalc','diffuco', '', &
+ &                   'temperature incorect.')
+    ELSE
+      lo = MINLOC(temp_in(:))
+      WRITE(numout,*) &
+ &     'Minimum temperature ( ',MINVAL(temp_in),') found at ',lo(1)
+      WHERE (jt(:) <= min_temp)   jt(:) = min_temp
+    ENDIF
+  ENDIF
+!-
+  DO ji = 1, kjpindex
+    zz_f(ji) = temp_in(ji)-FLOAT(jt(ji))
+    zz_a(ji) = qsfrict(jt(ji))
+    zz_b(ji) = qsfrict(jt(ji)+1)
+  ENDDO
+!-
+! 2. interpolates between this two values
+!-
+  DO ji = 1, kjpindex
+    qsat_out(ji) = ((zz_b(ji)-zz_a(ji))*zz_f(ji)+zz_a(ji))/pres_in(ji)
+  ENDDO
+!----------------------
+END SUBROUTINE qsatcalc
+!===
+FUNCTION qsat (temp_in,pres_in) RESULT (qsat_result)
+!!--------------------------------------------------------------------
+!! FUNCTION qsat (temp_in, pres_in) RESULT (qsat_result)
+!!--------------------------------------------------------------------
+  REAL(r_std),INTENT(in) :: temp_in  ! Temperature in degre Kelvin
+  REAL(r_std),INTENT(in) :: pres_in  ! Pressure
+  REAL(r_std) :: qsat_result
+!-
+  INTEGER(i_std)        :: jt
+  REAL(r_std)     :: zz_a,zz_b,zz_f
+!---------------------------------------------------------------------
+  IF (l_qsat_first) THEN
+    CALL qsfrict_init
+    l_qsat_first = .FALSE.
+  ENDIF
+!-
+! 1. computes qsat interpolation into two successive temperature
+!-
+  jt = INT(temp_in)
+!-
+  IF (jt >= max_temp-1) THEN
+    WRITE(numout,*) &
+ &   ' We stop. temperature too BIG : ',temp_in, &
+ &   ' approximation for : ',jt
+    IF (.NOT.diag_qsat) THEN
+      CALL ipslerr(2,'qsat','', '',&
+ &                   'temperature incorect.')
+    ELSE
+      qsat_result = 999999.
+      RETURN
+    ENDIF
+  ENDIF
+!-
+  IF (jt <= min_temp ) THEN
+    WRITE(numout,*) &
+ &   ' We stop. temperature too SMALL : ',temp_in, &
+ &   ' approximation for : ',jt
+    IF (.NOT.diag_qsat) THEN
+      CALL ipslerr(2,'qsat','', '',&
+ &                   'temperature incorect.')
+    ELSE
+      qsat_result = -999999.
+      RETURN
+    ENDIF
+  ENDIF
+!-
+  zz_f = temp_in-FLOAT(jt)
+  zz_a = qsfrict(jt)
+  zz_b = qsfrict(jt+1)
+!-
+! 2. interpolates between this two values
+!-
+  qsat_result = ((zz_b-zz_a)*zz_f+zz_a)/pres_in
+!----------------
+END FUNCTION qsat
+!===
+SUBROUTINE dev_qsatcalc (kjpindex,temp_in,pres_in,dev_qsat_out)
+!---------------------------------------------------------------------
+! Domain size
+  INTEGER(i_std),INTENT(in)                  :: kjpindex
+! Temperature in degre Kelvin
+  REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: temp_in
+! Pressure
+  REAL(r_std),DIMENSION(kjpindex),INTENT(in)  :: pres_in
+! Result
+  REAL(r_std),DIMENSION(kjpindex),INTENT(out) :: dev_qsat_out
+!-
+  INTEGER(i_std),DIMENSION(kjpindex) :: jt
+  INTEGER(i_std)                     :: ji
+  REAL(r_std),DIMENSION(kjpindex)     :: zz_a, zz_b, zz_c, zz_f
+  INTEGER(i_std)                     :: nbad
+!---------------------------------------------------------------------
+  IF (l_qsat_first) THEN
+    CALL qsfrict_init
+    l_qsat_first = .FALSE.
+  ENDIF
+!-
+! 1. computes qsat interpolation into two successive temperature
+!-
+  jt = INT(temp_in(:)+undemi)
+!-
+  nbad = COUNT( jt(:) >= max_temp-1 )
+  IF (nbad > 0) THEN
+    WRITE(numout,*) &
+ &   ' dev_qsatcalc: temperature too high at ',nbad,' points.'
+    IF (.NOT.diag_qsat) THEN
+      CALL ipslerr(3,'dev_qsatcalc','', '', &
+ &                   'temperature incorect.')
+    ELSE
+      WHERE (jt(:) >= max_temp-1)   jt(:) = max_temp-1
+    ENDIF
+  ENDIF
+!-
+  nbad = COUNT( jt(:) <= min_temp )
+  IF (nbad > 0) THEN
+    WRITE(numout,*) &
+ &   ' dev_qsatcalc: temperature too low at ',nbad,' points.'
+    IF (.NOT.diag_qsat) THEN
+      CALL ipslerr(3,'dev_qsatcalc', '', '',&
+ &                   'temperature incorect.')
+    ELSE
+      WHERE (jt(:) <= min_temp)   jt(:) = min_temp
+    ENDIF
+  ENDIF
+!-
+  DO ji=1,kjpindex
+    zz_f(ji) = temp_in(ji)+undemi-FLOAT(jt(ji))
+    zz_a(ji) = qsfrict(jt(ji)-1)
+    zz_b(ji) = qsfrict(jt(ji))
+    zz_c(ji) = qsfrict(jt(ji)+1)
+  ENDDO
+!-
+! 2. interpolates between this two values
+!-
+  DO ji = 1, kjpindex
+    dev_qsat_out(ji) = &
+ &   ((zz_c(ji)-deux*zz_b(ji)+zz_a(ji))*(zz_f(ji)-un) + &
+ &                         zz_c(ji)-zz_b(ji))/pres_in(ji)
+  ENDDO
+!--------------------------
+END SUBROUTINE dev_qsatcalc
+!===
+FUNCTION dev_qsat (temp_in,pres_in) RESULT (dev_qsat_result)
+!!--------------------------------------------------------------------
+!! FUNCTION dev_qsat (temp_in, pres_in) RESULT (dev_qsat_result)
+!! computes deviation of qsat
+!!--------------------------------------------------------------------
+  REAL(r_std),INTENT(in)  :: pres_in    ! Pressure
+  REAL(r_std),INTENT(in)  :: temp_in    ! Temperture in degre Kelvin
+  REAL(r_std) :: dev_qsat_result
+!-
+  INTEGER(i_std)        :: jt
+  REAL(r_std)     :: zz_a, zz_b, zz_c, zz_f
+!---------------------------------------------------------------------
+  IF (l_qsat_first) THEN
+    CALL qsfrict_init
+    l_qsat_first = .FALSE.
+  ENDIF
+!-
+! 1. computes qsat deviation interpolation
+!    into two successive temperature
+!-
+  jt = INT(temp_in+undemi)
+!-
+  IF (jt >= max_temp-1) THEN
+    WRITE(numout,*) &
+ &   ' We stop. temperature too HIGH : ',temp_in, &
+ &   ' approximation for : ',jt
+    IF (.NOT.diag_qsat) THEN
+      CALL ipslerr(3,'dev_qsat','', '',&
+ &                   'temperature incorect.')
+    ELSE
+      dev_qsat_result = 999999.
+        RETURN
+    ENDIF
+  ENDIF
+!-
+  IF (jt <= min_temp ) THEN
+    WRITE(numout,*) &
+ &   ' We stop. temperature too LOW : ',temp_in, &
+ &   ' approximation for : ',jt
+    IF (.NOT.diag_qsat) THEN
+      CALL ipslerr(3,'dev_qsat','', '',&
+ &                    'temperature incorect.')
+    ELSE
+      dev_qsat_result = -999999.
+        RETURN
+    ENDIF
+  ENDIF
+!-
+  zz_f = temp_in+undemi-FLOAT(jt)
+  zz_a = qsfrict(jt-1)
+  zz_b = qsfrict(jt)
+  zz_c = qsfrict(jt+1)
+!-
+! 2. interpolates
+!-
+  dev_qsat_result=((zz_c-deux*zz_b+zz_a)*(zz_f-un)+zz_c-zz_b)/pres_in
+!--------------------
+END FUNCTION dev_qsat
+!===
+SUBROUTINE qsfrict_init
+!!--------------------------------------------------------------------
+!! The qsfrict_init routine initialises qsfrict array
+!! to store precalculated value for qsat
+!!--------------------------------------------------------------------
+  INTEGER(i_std)        :: ji
+  REAL(r_std)     :: zrapp,zcorr,ztemperature,zqsat
+!---------------------------------------------------------------------
+! initialisation
+  zrapp = msmlr_h2o/msmlr_air
+  zcorr = 0.00320991_r_std
+! computes saturated humidity one time and store in qsfrict local array
+  DO ji=100,max_temp
+    ztemperature = FLOAT(ji)
+    IF (ztemperature < 273._r_std) THEN
+      zqsat = zrapp*10.0_r_std**(2.07023_r_std-zcorr*ztemperature &
+ &             -2484.896/ztemperature+3.56654*LOG10(ztemperature))
+    ELSE
+      zqsat = zrapp*10.0**(23.8319-2948.964/ztemperature &
+ &              -5.028*LOG10(ztemperature) &
+ &              -29810.16*EXP(-0.0699382*ztemperature) &
+ &              +25.21935*EXP(-2999.924/ztemperature))
+    ENDIF
+    qsfrict (ji) = zqsat
+  ENDDO
+!-
+  qsfrict(1:100) = zero
+!-
+  IF (long_print) WRITE (numout,*) ' qsfrict_init done'
+!--------------------------
+END SUBROUTINE qsfrict_init
+!===
+FUNCTION tempfunc (temp_in) RESULT (tempfunc_result)
+!!--------------------------------------------------------------------
+!! FUNCTION tempfunc (temp_in) RESULT (tempfunc_result)
+!! this function interpolates value between ztempmin and ztempmax
+!! used for lai detection
+!!--------------------------------------------------------------------
+  REAL(r_std),INTENT(in)  :: temp_in  !! Temperature in degre Kelvin
+  REAL(r_std) :: tempfunc_result
+!-
+  REAL(r_std),PARAMETER :: ztempmin=273._r_std !! Temperature for laimin
+  REAL(r_std),PARAMETER :: ztempmax=293._r_std !! Temperature for laimax
+  REAL(r_std)           :: zfacteur           !! Interpolation factor
+!---------------------------------------------------------------------
+  zfacteur = un/(ztempmax-ztempmin)**2
+  IF     (temp_in > ztempmax) THEN
+    tempfunc_result = un
+  ELSEIF (temp_in < ztempmin) THEN
+    tempfunc_result = zero
+  ELSE
+    tempfunc_result = un-zfacteur*(ztempmax-temp_in)**2
+  ENDIF
+!--------------------
+END FUNCTION tempfunc
+!===
+SUBROUTINE get_vegcorr (nolson,vegcorr,nobiocorr)
+!---------------------------------------------------------------------
+  INTEGER(i_std),INTENT(in)                    :: nolson
+  REAL(r_std),DIMENSION(nolson,nvm),INTENT(out) :: vegcorr(nolson,nvm)
+  REAL(r_std),DIMENSION(nolson,nnobio),INTENT(out) :: nobiocorr
+!-
+  INTEGER(i_std)           :: ib
+  INTEGER(i_std),PARAMETER :: nolson94 = 94
+  INTEGER(i_std),PARAMETER :: nvm13 = 13
+!---------------------------------------------------------------------
+  IF (nolson /= nolson94) THEN
+    WRITE(numout,*) nolson,nolson94
+    CALL ipslerr(3,'get_vegcorr', '', '',&
+ &                 'wrong number of OLSON vegetation types.')
+  ENDIF
+  IF (nvm /= nvm13) THEN
+    WRITE(numout,*) nvm,nvm13
+    CALL ipslerr(3,'get_vegcorr', '', '',&
+ &                 'wrong number of SECHIBA vegetation types.')
+  ENDIF
+!-
+! 1 set the indices of non-biospheric surface types to 0.
+!-
+  nobiocorr(:,:) = 0.
+!-
+! 2 Here we construct the correspondance table
+!   between Olson and the following SECHIBA Classes.
+!   vegcorr(i,:)+nobiocorr(i,:) = 1.  for all i.
+!-
+! The modified OLSON types found in file carteveg5km.nc
+! created by Nicolas Viovy :
+!  1 Urban
+  vegcorr( 1,:) = &
+ & (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+!  2 Cool low sparse grassland
+  vegcorr( 2,:) = &
+ & (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+!  3 Cold conifer forest
+  vegcorr( 3,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+!  4 Cold deciduous conifer forest
+  vegcorr( 4,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0/)
+!  5 Cool Deciduous broadleaf forest
+  vegcorr( 5,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+!  6 Cool evergreen broadleaf forests
+  vegcorr( 6,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+!  7 Cool tall grasses and shrubs
+  vegcorr( 7,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+!  8 Warm C3 tall grasses and shrubs
+  vegcorr( 8,:) = &
+ & (/0.1, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+!  9 Warm C4 tall grases and shrubs
+  vegcorr( 9,:) = &
+ & (/0.1, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0/)
+! 10 Bare desert
+  vegcorr(10,:) = &
+ & (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 11 Cold upland tundra
+  vegcorr(11,:) = &
+ & (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+! 12 Cool irrigated grassland
+  vegcorr(12,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0/)
+! 13 Semi desert
+  vegcorr(13,:) = &
+ & (/0.7, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
+! 14 Glacier ice
+  vegcorr(14,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+    nobiocorr(14,iice) = 1.
+! 15 Warm wooded wet swamp
+  vegcorr(15,:) = &
+ & (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0/)
+! 16 Inland water
+  vegcorr(16,:) = &
+ & (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 17 sea water
+  vegcorr(17,:) = &
+ & (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 18 cool shrub evergreen
+  vegcorr(18,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 19 cold shrub deciduous
+  vegcorr(19,:) = &
+ & (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 20 Cold evergreen forest and fields
+  vegcorr(20,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0/)
+! 21 cool rain forest
+  vegcorr(21,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
+! 22 cold conifer boreal forest
+  vegcorr(22,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
+! 23 cool conifer forest
+  vegcorr(23,:) = &
+ & (/0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
+! 24 warm mixed forest
+  vegcorr(24,:) = &
+ & (/0.0, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0/)
+! 25 cool mixed forest
+  vegcorr(25,:) = &
+ & (/0.0, 0.0, 0.0, 0.4, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
+! 26 cool broadleaf forest
+  vegcorr(26,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
+! 27 cool deciduous broadleaf forest
+  vegcorr(27,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.3, 0.5, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
+! 28 warm montane tropical forest
+  vegcorr(28,:) = &
+ & (/0.0, 0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0/)
+! 29 warm seasonal tropical forest
+  vegcorr(29,:) = &
+ & (/0.0, 0.5, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0/)
+! 30 cool crops and towns
+  vegcorr(30,:) = &
+ & (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
+! 31 warm crops and towns
+  vegcorr(31,:) = &
+ & (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8/)
+! 32 cool crops and towns
+  vegcorr(32,:) = &
+ & (/0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
+! 33 warm dry tropical woods
+  vegcorr(33,:) = &
+ & (/0.2, 0.0, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
+! 34 warm tropical rain forest
+  vegcorr(34,:) = &
+ & (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 35 warm tropical degraded forest
+  vegcorr(35,:) = &
+ & (/0.1, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0/)
+! 36 warm corn and beans cropland
+  vegcorr(36,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
+! 37 cool corn and bean cropland
+  vegcorr(37,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
+! 38 warm rice paddy and field
+  vegcorr(38,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
+! 39 hot irrigated cropland
+  vegcorr(39,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0/)
+! 40 cool irrigated cropland
+  vegcorr(40,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
+! 41 cold irrigated cropland
+  vegcorr(41,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
+! 42 cool grasses and shrubs
+  vegcorr(42,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
+! 43 hot and mild grasses and shrubs
+  vegcorr(43,:) = &
+ & (/0.2, 0.0, 0.1, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0/)
+! 44 cold grassland
+  vegcorr(44,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.0/)
+! 45 Savanna (woods) C3
+  vegcorr(45,:) = &
+ & (/0.1, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
+! 46 Savanna woods C4
+  vegcorr(46,:) = &
+ & (/0.1, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0/)
+! 47 Mire, bog, fen
+  vegcorr(47,:) = &
+ & (/0.1, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.0/)
+! 48 Warm marsh wetland
+  vegcorr(48,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+! 49 cold marsh wetland
+  vegcorr(49,:) = &
+ & (/0.0, 0.0, 0.0, 0.1, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+! 50 mediteraean scrub
+  vegcorr(50,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+! 51 Cool dry woody scrub
+  vegcorr(51,:) = &
+ & (/0.3, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 52 Warm dry evergreen woods
+  vegcorr(52,:) = &
+ & (/0.1, 0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 53 Volcanic rocks
+  vegcorr(53,:) = &
+ & (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 54 sand desert
+  vegcorr(54,:) = &
+ & (/1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 55 warm semi desert shrubs
+  vegcorr(55,:) = &
+ & (/0.7, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
+! 56 cool semi desert shrubs
+  vegcorr(56,:) = &
+ & (/0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0/)
+! 57 semi desert sage
+  vegcorr(57,:) = &
+ & (/0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 58 Barren tundra
+  vegcorr(58,:) = &
+ & (/0.6, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0/)
+! 59 cool southern hemisphere mixed forest
+  vegcorr(59,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
+! 60 cool fields and woods
+  vegcorr(60,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
+! 61 warm forest and filed
+  vegcorr(61,:) = &
+ & (/0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6/)
+! 62 cool forest and field
+  vegcorr(62,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
+! 63 warm C3 fields and woody savanna
+  vegcorr(63,:) = &
+ & (/0.1, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
+! 64 warm C4 fields and woody savanna
+  vegcorr(64,:) = &
+ & (/0.1, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6/)
+! 65 cool fields and woody savanna
+  vegcorr(65,:) = &
+ & (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
+! 66 warm succulent and thorn scrub
+  vegcorr(66,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0/)
+! 67 cold small leaf mixed woods
+  vegcorr(67,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.3, 0.0, 0.5, 0.0, 0.0, 0.0/)
+! 68 cold deciduous and mixed boreal fores
+  vegcorr(68,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.7, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0/)
+! 69 cold narrow conifers
+  vegcorr(69,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
+! 70 cold wooded tundra
+  vegcorr(70,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.7, 0.0, 0.0, 0.0/)
+! 71 cold heath scrub
+  vegcorr(71,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.7, 0.0, 0.0, 0.0/)
+! 72 Polar and alpine desert
+  vegcorr(72,:) = &
+ & (/0.9, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.1, 0.0, 0.0, 0.0/)
+! 73 warm Mangrove
+  vegcorr(73,:) = &
+ & (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 74 cool crop and water mixtures
+  vegcorr(74,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0/)
+! 75 cool southern hemisphere mixed forest
+  vegcorr(75,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
+! 76 cool moist eucalyptus
+  vegcorr(76,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0/)
+! 77 warm rain green tropical forest
+  vegcorr(77,:) = &
+ & (/0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+! 78 warm C3 woody savanna
+  vegcorr(78,:) = &
+ & (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 79 warm C4 woody savanna
+  vegcorr(79,:) = &
+ & (/0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 80 cool woody savanna
+  vegcorr(80,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 81 cold woody savanna
+  vegcorr(81,:) = &
+ & (/0.0, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, 0.6, 0.0, 0.0, 0.0/)
+! 82 warm broadleaf crops
+  vegcorr(82,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0/)
+! 83 warm C3 grass crops
+  vegcorr(83,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9, 0.0/)
+! 84 warm C4 grass crops
+  vegcorr(84,:) = &
+ & (/0.1, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.9/)
+! 85 cool grass crops
+  vegcorr(85,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0/)
+! 86 warm C3 crops grass,shrubs
+  vegcorr(86,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0/)
+! 87 cool crops,grass,shrubs
+  vegcorr(87,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.5, 0.0, 0.5, 0.0/)
+! 88 warm evergreen tree crop
+  vegcorr(88,:) = &
+ & (/0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2/)
+! 89 cool evergreen tree crop
+  vegcorr(89,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
+! 90 cold evergreen tree crop
+  vegcorr(90,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
+! 91 warm deciduous tree crop
+  vegcorr(91,:) = &
+ & (/0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2/)
+! 92 cool deciduous tree crop
+  vegcorr(92,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, 0.2, 0.0/)
+! 93 cold deciduous tree crop
+  vegcorr(93,:) = &
+ & (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0, 0.2, 0.0/)
+! 94 wet sclerophylic forest
+  vegcorr(94,:) = &
+ & (/0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
+!-
+! 3 Check the mapping for the Olson types which are going into the
+!   the veget and nobio array.
+!-
+  DO ib=1,nolson
+    IF ( ABS(SUM(vegcorr(ib,:))+SUM(nobiocorr(ib,:))-1.0) &
+ &       > EPSILON(1.0)) THEN
+      WRITE(numout,*) 'Wrong correspondance for Olson type :', ib
+      CALL ipslerr(3,'get_vegcorr', '', '',&
+ &                 'Wrong correspondance for Olson type.')
+    ENDIF
+  ENDDO
+!-------------------------
+END SUBROUTINE get_vegcorr
+!===
+SUBROUTINE get_soilcorr (nzobler,textfrac_table)
+!!--------------------------------------------------------------------
+!! The "get_soilcorr" routine defines the table of correspondence
+!! between the Zobler types and the three texture
+!! types known by SECHIBA & STOMATE : silt, sand and clay
+!!--------------------------------------------------------------------
+  INTEGER(i_std),INTENT(in)                      :: nzobler
+  REAL(r_std),DIMENSION(nzobler,nstm),INTENT(out) :: textfrac_table
+!-
+  INTEGER(i_std),PARAMETER :: nbtypes_zobler = 7
+  INTEGER(i_std) :: ib
+!---------------------------------------------------------------------
+  IF (nzobler /= nbtypes_zobler) THEN
+    CALL ipslerr(3,'get_soilcorr', 'nzobler /= nbtypes_zobler',&
+ &   'We do not have the correct number of classes', &
+ &                 ' in the code for the file.')
+  ENDIF
+!-
+! Textural fraction for : silt        sand         clay
+!-
+  textfrac_table(1,:) = (/ 0.12, 0.82, 0.06 /)
+  textfrac_table(2,:) = (/ 0.32, 0.58, 0.10 /)
+  textfrac_table(3,:) = (/ 0.39, 0.43, 0.18 /)
+  textfrac_table(4,:) = (/ 0.15, 0.58, 0.27 /)
+  textfrac_table(5,:) = (/ 0.34, 0.32, 0.34 /)
+  textfrac_table(6,:) = (/ 0.00, 1.00, 0.00 /)
+  textfrac_table(7,:) = (/ 0.39, 0.43, 0.18 /)
+
+  DO ib=1,nzobler
+    IF (ABS(SUM(textfrac_table(ib,:))-1.0) > EPSILON(1.0)) THEN
+      WRITE(numout,*) &
+ &     'Error in the correspondence table', &
+ &     ' sum is not equal to 1 in', ib
+    WRITE(numout,*) textfrac_table(ib,:)
+       CALL ipslerr(3,'get_soilcorr', 'SUM(textfrac_table(ib,:)) /= 1.0',&
+ &                 '', 'Error in the correspondence table')
+    ENDIF
+  ENDDO
+!--------------------------
+END SUBROUTINE GET_soilcorr
+!===
+!------------------------
+END MODULE constantes_veg
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/AA_make
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/AA_make	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/AA_make	(revision 55)
@@ -0,0 +1,171 @@
+#-
+#- $Id$
+#-
+PARALLEL_LIB = $(LIBDIR)/libparallel.a
+SXPARALLEL_LIB = $(PARALLEL_LIB)
+#-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-
+PARAM_LIB = $(LIBDIR)/libparameters.a
+SXPARAM_LIB = $(PARAM_LIB)
+#-Q- sxnec  SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx6nec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- eshpux SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-
+ORGLOB_LIB = $(LIBDIR)/liborglob.a
+SXORGLOB_LIB = $(ORGLOB_LIB)
+#-Q- sxnec  SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- sx6nec SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- eshpux SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- sx8brodie SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-
+STOMATE_LIB = $(LIBDIR)/libstomate.a
+SXSTOMATE_LIB = $(STOMATE_LIB)
+#-Q- sxnec  SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
+#-Q- sx6nec SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
+#-Q- eshpux SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
+#-Q- sx8brodie SXSTOMATE_LIB = $(LIBDIR)/libsxstomate.a
+#-
+MODS1 =              \
+  sechiba_io_p.f90   \
+  sechiba_io.f90     \
+  watchout.f90       \
+  slowproc.f90       \
+  diffuco.f90        \
+  condveg.f90        \
+  enerbil.f90        \
+  hydrol.f90         \
+  hydrolc.f90        \
+  thermosoil.f90     \
+  routing.f90        \
+  sechiba.f90        \
+  intersurf.f90 
+OBJSMODS1 = $(MODS1:.f90=.o)
+#-
+.PRECIOUS : $(MODEL_LIB)
+#-Q- sxnec  .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
+#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
+#-
+all:
+	$(M_K) libparallel
+	$(M_K) libparameters
+	$(M_K) liborglob
+	$(M_K) libstomate
+	$(M_K) m_all
+	@echo sechiba is OK
+
+m_all: $(MODEL_LIB)($(OBJSMODS1))
+#-Q- intel m_all: WORK_MOD $(MODEL_LIB)($(OBJSMODS1))
+
+libparallel:
+	(cd ../src_parallel; $(M_K) -f Makefile)
+
+libparameters:
+	(cd ../src_parameters; $(M_K) -f Makefile)
+
+liborglob:
+	(cd ../src_global; $(M_K) -f Makefile)
+
+libstomate:
+	(cd ../src_stomate; $(M_K) -f Makefile)
+
+$(MODEL_LIB)(%.o) : %.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
+	$(A_C) $(MODEL_LIB) $*.o
+#-Q- sxnec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sxnec 	mv $*.mod $(MODDIR)
+#-Q- sx6nec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx6nec 	mv $*.mod $(MODDIR)
+#-Q- eshpux 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- eshpux 	mv $*.mod $(MODDIR)
+#-Q- sx8mercure 	mv $*.mod $(MODDIR)
+#-Q- sx9mercure 	mv $*.mod $(MODDIR)
+#-Q- sx8brodie	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx8brodie	mv $*.mod $(MODDIR)
+#-Q- solaris 	mv $*.mod $(MODDIR)
+	$(RM) $*.o
+#-Q- intel
+#-Q- intel WORK_MOD :
+#-Q- intel 	$(RM) work.pcl
+#-Q- intel 	@echo "work.pc" > work.pcl
+#-Q- intel 	@echo "../src_parameters/work.pc" >> work.pcl
+#-Q- intel 	@echo "../src_stomate/work.pc" >> work.pcl
+#-Q- intel 	@echo "../../IOIPSL/src/work.pc" >> work.pcl
+
+config : 
+	$(BINDIR)/Fparser -name SECHIBA $(MODS1)
+	echo 'Configuration of SECHIBA done'
+
+clean:
+	$(RM) $(MODEL_LIB)
+
+$(MODEL_LIB)(sechiba.o):          \
+  $(PARAM_LIB)(constantes_co2.o)  \
+  $(MODEL_LIB)(sechiba_io_p.o)    \
+  $(MODEL_LIB)(sechiba_io.o)      \
+  $(MODEL_LIB)(diffuco.o)         \
+  $(MODEL_LIB)(condveg.o)         \
+  $(MODEL_LIB)(enerbil.o)         \
+  $(MODEL_LIB)(hydrolc.o)         \
+  $(MODEL_LIB)(hydrol.o)          \
+  $(MODEL_LIB)(thermosoil.o)      \
+  $(MODEL_LIB)(slowproc.o)        \
+  $(MODEL_LIB)(routing.o)
+ 
+$(MODEL_LIB)(sechiba_io_p.o): \
+  $(PARAM_LIB)(constantes_veg.o) \
+  $(PARALLEL_LIB)(parallel.o)
+
+$(MODEL_LIB)(sechiba_io.o): \
+  $(MODEL_LIB)(sechiba_io_p.o) \
+  $(PARAM_LIB)(constantes_veg.o)
+
+$(MODEL_LIB)(watchout.o): \
+  $(ORGLOB_LIB)(grid.o)
+
+$(MODEL_LIB)(hydrol.o):           \
+  $(PARAM_LIB)(constantes_veg.o)  \
+  $(MODEL_LIB)(sechiba_io.o)      \
+  $(ORGLOB_LIB)(grid.o)
+
+$(MODEL_LIB)(hydrolc.o):          \
+  $(PARAM_LIB)(constantes_veg.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(slowproc.o):         \
+  $(PARAM_LIB)(constantes_co2.o)  \
+  $(STOMATE_LIB)(stomate.o)       \
+  $(MODEL_LIB)(sechiba_io.o)      \
+  $(ORGLOB_LIB)(interpol_help.o)
+
+$(MODEL_LIB)(diffuco.o):          \
+  $(PARAM_LIB)(constantes_co2.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(enerbil.o):          \
+  $(PARAM_LIB)(constantes_veg.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(condveg.o):          \
+  $(PARAM_LIB)(constantes_veg.o)  \
+  $(ORGLOB_LIB)(interpol_help.o)
+
+$(MODEL_LIB)(thermosoil.o): \
+  $(PARAM_LIB)(constantes_soil.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(routing.o):          \
+  $(PARAM_LIB)(constantes_veg.o)  \
+  $(MODEL_LIB)(sechiba_io.o)
+
+$(MODEL_LIB)(intersurf.o): \
+  $(PARAM_LIB)(constantes_veg.o)  \
+  $(ORGLOB_LIB)(grid.o)           \
+  $(MODEL_LIB)(watchout.o)        \
+  $(MODEL_LIB)(sechiba.o)
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/AA_make.ldef
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/AA_make.ldef	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/AA_make.ldef	(revision 55)
@@ -0,0 +1,18 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a SECHIBA
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+MODEL_LIB = $(LIBDIR)/libsechiba.a
+SXMODEL_LIB = $(MODEL_LIB)
+#-Q- sxnec  SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
+#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
+#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
+#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxsechiba.a
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/condveg.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/condveg.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/condveg.f90	(revision 55)
@@ -0,0 +1,1220 @@
+!!
+!! This module computes surface conditions
+!! - albedo
+!! - roughness
+!! - emissivity
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!! 
+MODULE condveg
+  !
+  USE ioipsl
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_veg
+  USE interpol_help
+  USE parallel
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! condveg_main only
+  PRIVATE
+  PUBLIC :: condveg_main,condveg_clear 
+
+  !
+  ! variables used inside condveg module : declaration and initialisation
+  !
+  LOGICAL, SAVE                     :: l_first_condveg=.TRUE.           !! To keep first call's trace
+  LOGICAL, SAVE                     :: z0cdrag_ave=.FALSE.              !! Chooses the method for the z0 average
+  !
+  REAL(r_std), SAVE                  :: fixed_snow_albedo                !! In case we wish a fxed snow albedo
+  INTEGER(i_std), PARAMETER         :: ivis = 1                         !! index for visible albedo
+  INTEGER(i_std), PARAMETER         :: inir = 2                         !! index for near infrared albedo
+  LOGICAL, SAVE                     :: impaze                           !! Choice on the surface parameters
+  !
+  REAL(r_std), SAVE                  :: z0_scal                          !! Roughness used to initialize the scheme
+  REAL(r_std), SAVE                  :: roughheight_scal                 !! Height to displace the surface 
+                                                                        !! from the zero wind height.
+  REAL(r_std), SAVE                  :: albedo_scal(2)                   !! Two albedos used to initialize the scheme
+  REAL(r_std), SAVE                  :: emis_scal                        !! Surface emissivity  used to initialize the scheme
+  !
+  REAL(r_std), ALLOCATABLE, SAVE     :: soilalb_dry(:,:)                 !! albedo for the dry bare soil
+  REAL(r_std), ALLOCATABLE, SAVE     :: soilalb_wet(:,:)                 !! albedo for the wet bare soil
+  ! Ajout Nathalie pour autre calcul soilalbedo
+  REAL(r_std), ALLOCATABLE, SAVE     :: soilalb_moy(:,:)                 !! mean soil albedo
+  REAL(r_std), PARAMETER             :: z0_over_height = un/16.          !! to get z0 from height
+  REAL(r_std), PARAMETER             :: height_displacement = 0.75       !! Magic number which relates the 
+                                                                          !! height to the displacement height.
+  ! Ajouts Nathalie - Septembre 2008
+  REAL(r_std), ALLOCATABLE, SAVE :: alb_bare(:,:)                         !! Soil Albedo, vis(1) and nir(2)
+  REAL(r_std), ALLOCATABLE, SAVE :: alb_veget(:,:)                        !! Vegetation Albedo, vis(1) and nir(2)
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)  :: albedo_snow      !! Snow albedo
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)  :: albedo_glob      !! Mean albedo
+  !
+  LOGICAL, SAVE                                  :: alb_bare_model   !! Switch to old (albedo bare depend on soil wetness) 
+                                                                     !! or new one (mean of soilalb)
+
+CONTAINS
+
+  !! 
+  !! Main routine for *condveg* module
+  !! - called only one time for initialisation
+  !! - called every time step
+  !! - called one more time at last time step for writing _restart_ file
+  !!
+  !! Algorithm:
+  !! - call condveg_init for initialisation
+  !! - call condveg_var_init for initialisation done every time step
+  !! - call condveg_snow for computing the modification of the albedo induced by snow cover
+  !!
+  !!  @call condveg_init
+  !!  @call condveg_var_init
+  !!  @call condveg_snow
+  !!
+  !!
+  SUBROUTINE condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index,&
+       & lalo, neighbours, resolution, contfrac, veget, veget_max, frac_nobio, totfrac_nobio, &
+       & zlev, snow, snow_age, snow_nobio, snow_nobio_age, &
+       & drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, soiltype, rest_id, hist_id, hist2_id)
+
+    ! interface description:
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                       :: kjit             !! Time step number 
+    INTEGER(i_std), INTENT(in)                       :: kjpindex         !! Domain size
+    INTEGER(i_std),INTENT (in)                       :: rest_id          !! _Restart_ file identifier
+    INTEGER(i_std),INTENT (in)                       :: hist_id          !! _History_ file identifier
+    INTEGER(i_std), OPTIONAL, INTENT (in)            :: hist2_id          !! _History_ file 2 identifier
+    REAL(r_std), INTENT (in)                         :: dtradia          !! Time step in seconds
+    LOGICAL, INTENT(in)                             :: ldrestart_read   !! Logical for restart file to read
+    LOGICAL, INTENT(in)                             :: ldrestart_write  !! Logical for restart file to write
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index            !! Indeces of the points on the map
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)  :: lalo             !! Geographical coordinates
+    INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in):: neighbours       !! neighoring grid points if land
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)  :: resolution       !! size in x an y of the grid (m)
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)    :: contfrac         ! Fraction of land in each grid box.
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget            !! Fraction of vegetation types
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget_max        !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio    !! Fraction of continental ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: totfrac_nobio    !! total fraction of continental ice+lakes+...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)    :: zlev             !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: snow             !! Snow mass [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: snow_age         !! Snow age
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio    !! Snow mass [Kg/m^2] on ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: snow_nobio_age   !! Snow age on ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: drysoil_frac     !! Fraction of visibly Dry soil(between 0 and 1)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: height           !! Vegetation Height (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: deadleaf_cover   !! Fraction of soil covered by dead leaves
+    ! output scalar
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: emis             !! Emissivity
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo           !! Albedo, vis(1) and nir(2)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: z0               !! Roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: roughheight      !! Effective height for roughness
+    REAL(r_std),DIMENSION (kjpindex,nstm), INTENT (in) :: soiltype       !! fraction of soil types
+    ! local
+    CHARACTER(LEN=80)                               :: var_name         !! To store variables names for I/O
+    !
+    IF (l_first_condveg) THEN
+
+        IF (long_print) WRITE (numout,*) ' l_first_condveg : call condveg_init '
+
+        CALL condveg_init (kjit, ldrestart_read, kjpindex, index, veget, &
+                           lalo, neighbours, resolution, contfrac, rest_id)
+        CALL condveg_var_init (ldrestart_read, kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, &
+             & drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
+        ! Nathalie - Fevrier 2007 - c'est veget_max qu'il faut passer
+        ! Sauf en cas de DGVM .... pour le moment car la somme des maxvegetfrac depasse 1!
+        ! Si DGVM alors on passe veget.
+        IF (control%ok_dgvm) THEN
+           CALL condveg_snow (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
+                snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
+        ELSE
+           CALL condveg_snow (ldrestart_read, kjpindex, veget_max, frac_nobio, totfrac_nobio, &
+                snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
+        ENDIF
+
+        RETURN
+
+    ENDIF
+
+    CALL condveg_var_update (ldrestart_read, kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, &
+         & drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
+    ! Nathalie - Fevrier 2007 - c'est veget_max qu'il faut passer
+    ! Sauf en cas de DGVM .... pour le moment car la somme des maxvegetfrac depasse 1!
+    ! Si DGVM alors on passe veget.
+    IF (control%ok_dgvm) THEN
+       CALL condveg_snow (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
+            snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
+    ELSE 
+       CALL condveg_snow (ldrestart_read, kjpindex, veget_max, frac_nobio, totfrac_nobio, &
+            snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
+    ENDIF
+
+    IF (ldrestart_write) THEN
+       !
+       var_name = 'soilalbedo_dry'
+       CALL restput_p (rest_id, var_name, nbp_glo, 2, 1, kjit, soilalb_dry, 'scatter',  nbp_glo, index_g)
+       !
+       var_name = 'soilalbedo_wet'
+       CALL restput_p (rest_id, var_name, nbp_glo, 2, 1, kjit, soilalb_wet, 'scatter',  nbp_glo, index_g)
+       !
+       var_name = 'soilalbedo_moy'
+       CALL restput_p (rest_id, var_name, nbp_glo, 2, 1, kjit, soilalb_moy, 'scatter',  nbp_glo, index_g)
+       !
+       RETURN
+       !
+    ENDIF
+
+    IF ( almaoutput ) THEN
+       CALL histwrite(hist_id, 'Albedo', kjit, albedo_glob, kjpindex, index)
+       CALL histwrite(hist_id, 'SAlbedo', kjit, albedo_snow, kjpindex, index)
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'Albedo', kjit, albedo_glob, kjpindex, index)
+          CALL histwrite(hist2_id, 'SAlbedo', kjit, albedo_snow, kjpindex, index)
+       ENDIF
+    ELSE
+       CALL histwrite(hist_id, 'soilalb_vis', kjit, alb_bare(:,1), kjpindex, index)
+       CALL histwrite(hist_id, 'soilalb_nir', kjit, alb_bare(:,2), kjpindex, index)
+       CALL histwrite(hist_id, 'vegalb_vis',  kjit, alb_veget(:,1), kjpindex, index)
+       CALL histwrite(hist_id, 'vegalb_nir',  kjit, alb_veget(:,2), kjpindex, index)
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'soilalb_vis', kjit, alb_bare(:,1), kjpindex, index)
+          CALL histwrite(hist2_id, 'soilalb_nir', kjit, alb_bare(:,2), kjpindex, index)
+          CALL histwrite(hist2_id, 'vegalb_vis',  kjit, alb_veget(:,1), kjpindex, index)
+          CALL histwrite(hist2_id, 'vegalb_nir',  kjit, alb_veget(:,2), kjpindex, index)
+       ENDIF
+    ENDIF
+
+    IF (long_print) WRITE (numout,*)' condveg_main done '
+
+  END SUBROUTINE condveg_main
+
+  !! Algorithm:
+  !! - dynamic allocation for local array 
+  !!
+  SUBROUTINE condveg_init  (kjit, ldrestart_read, kjpindex, index, veget, &
+                            lalo, neighbours, resolution, contfrac, rest_id)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                       :: kjit             !! Time step number 
+    LOGICAL, INTENT(in)                             :: ldrestart_read   !! Logical for restart file to read
+    INTEGER(i_std), INTENT(in)                       :: kjpindex         !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in) :: index            !! Indeces of the points on the map
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in):: veget            !! Vegetation distribution
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)  :: lalo             !! Geographical coordinates
+    INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in):: neighbours       !! neighoring grid points if land
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)  :: resolution       !! size in x an y of the grid (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: contfrac         ! Fraction of land in each grid box.
+    INTEGER(i_std), INTENT(in)                       :: rest_id          !! Restart file identifier
+    ! input fields
+    ! output scalar
+    ! output fields
+
+    ! local declaration
+    INTEGER(i_std)                                  :: ji
+    INTEGER(i_std)                                  :: ier
+    CHARACTER(LEN=80)                               :: var_name         !! To store variables names for I/O
+    ! initialisation
+    IF (l_first_condveg) THEN 
+       !
+       ! Get the fixed snow albedo if needed
+       !
+       !
+       !Config Key  = CONDVEG_SNOWA
+       !Config Desc = The snow albedo used by SECHIBA
+       !Config Def  = DEF 
+       !Config Help = This option allows the user to impose a snow albedo.
+       !Config        Default behaviour is to use the model of snow albedo
+       !Config        developed by Chalita (1993).
+       !
+       fixed_snow_albedo = undef_sechiba
+       CALL getin_p('CONDVEG_SNOWA', fixed_snow_albedo)
+       !
+       !
+       !Config Key  = ALB_BARE_MODEL
+       !Config Desc = Switch bare soil albedo dependent (if TRUE) on soil wetness
+       !Config Def  = FALSE
+       !Config Help = If TRUE, the model for bare soil albedo is the old formulation.
+       !Config        Then it depend on the soil dry or wetness. If FALSE, it is the 
+       !Config        new computation that is taken, it is the mean of soil albedo.
+       !
+       alb_bare_model=.FALSE.
+       CALL getin_p('ALB_BARE_MODEL', alb_bare_model)
+       !       
+       l_first_condveg=.FALSE.
+       !
+       !  Allocate variables which have to
+       ! 
+       ALLOCATE (soilalb_dry(kjpindex,2),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in soilalb_dry allocation. We stop.We need kjpindex*2 words = ',kjpindex*2
+          STOP 'condveg_init'
+       END IF
+       soilalb_dry(:,:) = val_exp
+
+       ALLOCATE (soilalb_wet(kjpindex,2),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in soilalb_wet allocation. We stop.We need kjpindex*2 words = ',kjpindex*2
+          STOP 'condveg_init'
+       END IF
+       soilalb_wet(:,:) = val_exp
+
+        ! Ajout Nathalie
+       ALLOCATE (soilalb_moy(kjpindex,2),stat=ier)
+        IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in soilalb_moy allocation. We stop.We need kjpindex*2 words = ',kjpindex*2
+          STOP 'condveg_init'
+        END IF
+       soilalb_moy(:,:) = val_exp
+
+       ALLOCATE (albedo_snow(kjpindex),stat=ier)
+        IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in albedo_snow allocation. We stop.We need kjpindex words = ',kjpindex
+          STOP 'condveg_init'
+        END IF
+
+       ALLOCATE (albedo_glob(kjpindex),stat=ier)
+        IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in albedo_glob allocation. We stop.We need kjpindex words = ',kjpindex
+          STOP 'condveg_init'
+        END IF
+
+       ALLOCATE (alb_bare(kjpindex,2),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in alb_bare allocation. We stop.We need kjpindex*2 words = ',kjpindex*2
+          STOP 'condveg_init'
+       END IF
+       alb_bare(:,:) = val_exp
+
+       ALLOCATE (alb_veget(kjpindex,2),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in alb_veget allocation. We stop.We need kjpindex*2 words = ',kjpindex*2
+          STOP 'condveg_init'
+       END IF
+       alb_veget(:,:) = val_exp
+       !
+       !  Get the bare soil albedo
+       !
+       !
+       var_name= 'soilalbedo_dry'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Dry bare soil albedo')
+       CALL restget_p (rest_id, var_name, nbp_glo, 2, 1, kjit, .TRUE., soilalb_dry, "gather", nbp_glo, index_g)
+
+       var_name= 'soilalbedo_wet'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Wet bare soil albedo')
+       CALL restget_p (rest_id, var_name, nbp_glo, 2, 1, kjit, .TRUE., soilalb_wet, "gather", nbp_glo, index_g)
+
+       var_name= 'soilalbedo_moy'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Mean bare soil albedo')
+       CALL restget_p (rest_id, var_name, nbp_glo, 2, 1, kjit, .TRUE., soilalb_moy, "gather", nbp_glo, index_g)
+       !
+       IF ( MINVAL(soilalb_wet) .EQ. MAXVAL(soilalb_wet) .AND. MAXVAL(soilalb_wet) .EQ. val_exp .OR.&
+            & MINVAL(soilalb_dry) .EQ. MAXVAL(soilalb_dry) .AND. MAXVAL(soilalb_dry) .EQ. val_exp .OR.&
+            & MINVAL(soilalb_moy) .EQ. MAXVAL(soilalb_moy) .AND. MAXVAL(soilalb_moy) .EQ. val_exp) THEN
+          CALL condveg_soilalb(kjpindex, lalo, neighbours, resolution, contfrac, soilalb_dry,soilalb_wet)
+          WRITE(numout,*) '---> val_exp ', val_exp
+          WRITE(numout,*) '---> ALBEDO_wet VIS:', MINVAL(soilalb_wet(:,ivis)), MAXVAL(soilalb_wet(:,ivis))
+          WRITE(numout,*) '---> ALBEDO_wet NIR:', MINVAL(soilalb_wet(:,inir)), MAXVAL(soilalb_wet(:,inir))
+          WRITE(numout,*) '---> ALBEDO_dry VIS:', MINVAL(soilalb_dry(:,ivis)), MAXVAL(soilalb_dry(:,ivis))
+          WRITE(numout,*) '---> ALBEDO_dry NIR:', MINVAL(soilalb_dry(:,inir)), MAXVAL(soilalb_dry(:,inir))
+          WRITE(numout,*) '---> ALBEDO_moy VIS:', MINVAL(soilalb_moy(:,ivis)), MAXVAL(soilalb_moy(:,ivis))
+          WRITE(numout,*) '---> ALBEDO_moy NIR:', MINVAL(soilalb_moy(:,inir)), MAXVAL(soilalb_moy(:,inir))
+       ENDIF
+       !
+    ELSE 
+       WRITE (numout,*) ' l_first_condveg false . we stop '
+       STOP 'condveg_init'
+    ENDIF
+    !! test de commentaires
+
+    IF (long_print) WRITE (numout,*) ' condveg_init done '
+
+  END SUBROUTINE condveg_init
+  !!
+  !!
+  SUBROUTINE condveg_clear  ()
+
+      l_first_condveg=.TRUE.
+       
+       IF (ALLOCATED (soilalb_dry)) DEALLOCATE (soilalb_dry)
+       IF (ALLOCATED(soilalb_wet))  DEALLOCATE (soilalb_wet)
+       ! Ajout Nathalie
+       IF (ALLOCATED(soilalb_moy))  DEALLOCATE (soilalb_moy)
+       IF (ALLOCATED(albedo_snow))  DEALLOCATE (albedo_snow)
+       IF (ALLOCATED(albedo_glob))  DEALLOCATE (albedo_glob)
+       IF (ALLOCATED(alb_bare))  DEALLOCATE (alb_bare)
+       IF (ALLOCATED(alb_veget))  DEALLOCATE (alb_veget)
+       !
+  END SUBROUTINE condveg_clear
+
+  !! Algorithm:
+  !! - initialisation of local arry
+  !! - reads map for emissivity, albedo or roughness
+  !!
+  SUBROUTINE condveg_var_init  (ldrestart_read, kjpindex, veget, veget_max, frac_nobio, totfrac_nobio,&
+       & drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                       :: kjpindex         !! Domain size
+    LOGICAL, INTENT(in)                             :: ldrestart_read   !! Logical for _restart_ file to read
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget            !! Fraction of vegetation types
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget_max        !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio    !! Fraction of continental ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: totfrac_nobio    !! Total fraction of continental ice+lakes+...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: drysoil_frac     !! Fraction of visibly Dry soil(between 0 and 1)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)    :: zlev             !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: height           !! Vegetation Height (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: deadleaf_cover   !! Fraction of soil covered by dead leaves
+    ! output scalar
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: emis             !! Emissivity
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo           !! Albedo, vis(1) and nir(2)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: z0               !! Roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: roughheight      !! Effective height for roughness
+    !
+    ! local declaration
+    INTEGER(i_std)                                 :: ier               !! Error code
+    INTEGER(i_std)                                 :: jv
+    ! initialisation of variables
+    !
+
+    !
+    !Config Key  = IMPOSE_AZE
+    !Config Desc = Should the surface parameters be prescribed
+    !Config Def  = n
+    !Config Help = This flag allows the user to impose the surface parameters
+    !Config        (Albedo Roughness and Emissivity). It is espacially interesting for 0D
+    !Config        simulations. On the globe it does not make too much sense as
+    !Config        it imposes the same vegetation everywhere
+    !
+    impaze = .FALSE.
+    CALL getin_p('IMPOSE_AZE', impaze)
+
+    !!
+    !! calculs de emis
+    !!
+
+    IF ( impaze ) THEN
+       !
+       !Config Key  = CONDVEG_EMIS
+       !Config Desc = Emissivity of the surface for LW radiation
+       !Config Def  = 1.0
+       !Config If   = IMPOSE_AZE
+       !Config Help = The surface emissivity used for compution the LE emission
+       !Config        of the surface in a 0-dim version. Values range between 
+       !Config        0.97 and 1.. The GCM uses 0.98.
+       !
+       emis_scal = un
+       CALL getin_p('CONDVEG_EMIS', emis_scal)
+       emis(:) = emis_scal
+
+    ELSE
+       !  Some day it will be moisture dependent
+       emis_scal = un
+       
+       emis(:) = emis_scal
+    ENDIF
+
+    !!
+    !! calculs de albedo
+    !!
+    !
+    IF ( impaze ) THEN
+      !
+      !Config Key  = CONDVEG_ALBVIS
+      !Config Desc = SW visible albedo for the surface
+      !Config Def  = 0.25
+      !Config If   = IMPOSE_AZE
+      !Config Help = Surface albedo in visible wavelengths to be used 
+      !Config        on the point if a 0-dim version of SECHIBA is used. 
+      !Config        Look at the description of the forcing data for 
+      !Config        the correct value.
+      !
+        albedo_scal(ivis) = 0.25_r_std
+        CALL getin_p('CONDVEG_ALBVIS', albedo_scal(ivis))
+       albedo(:,ivis) = albedo_scal(ivis)
+      !
+      !Config Key  = CONDVEG_ALBNIR
+      !Config Desc = SW near infrared albedo for the surface
+      !Config Def  = 0.25
+      !Config If   = IMPOSE_AZE
+      !Config Help = Surface albedo in near infrared wavelengths to be used 
+      !Config        on the point if a 0-dim version of SECHIBA is used. 
+      !Config        Look at the description of the forcing data for 
+      !Config        the correct value.
+      !
+       albedo_scal(inir) = 0.25_r_std
+       CALL getin_p('CONDVEG_ALBNIR', albedo_scal(inir))
+       albedo(:,inir) = albedo_scal(inir)
+    ELSE
+       !
+       CALL condveg_albcalc (kjpindex,deadleaf_cover,veget,drysoil_frac,albedo)
+       !
+    ENDIF
+    !!
+    !! calculs de z0
+    !!
+    !
+    !Config Key  = Z0CDRAG_AVE
+    !Config Desc = Average method for z0
+    !Config Def  = y
+    !Config Help = If this flag is set to true (y) then the neutral Cdrag
+    !Config        is averaged instead of the log(z0). This should be
+    !Config        the prefered option. We still wish to keep the other
+    !Config        option so we can come back if needed. If this is
+    !Config        desired then one should set Z0CDRAG_AVE=n
+    z0cdrag_ave = .TRUE.
+    CALL getin_p('Z0CDRAG_AVE', z0cdrag_ave)
+    !!
+    IF ( impaze ) THEN
+      !
+      !Config Key  = CONDVEG_Z0
+      !Config Desc = Surface roughness (m)
+      !Config Def  = 0.15
+      !Config If   = IMPOSE_AZE
+      !Config Help = Surface rougness to be used on the point if a 0-dim version
+      !Config        of SECHIBA is used. Look at the description of the forcing  
+      !Config        data for the correct value.
+      !
+      z0_scal = 0.15_r_std
+      CALL getin_p('CONDVEG_Z0', z0_scal)
+      z0(:) = z0_scal
+      !
+      !Config Key  = ROUGHHEIGHT
+      !Config Desc = Height to be added to the height of the first level (m)
+      !Config Def  = 0.0
+      !Config If   = IMPOSE_AZE
+      !Config Help = ORCHIDEE assumes that the atmospheric level height is counted
+      !Config        from the zero wind level. Thus to take into account the roughness
+      !Config        of tall vegetation we need to correct this by a certain fraction
+      !Config        of the vegetation height. This is called the roughness height in
+      !Config        ORCHIDEE talk.
+      !
+      roughheight_scal = zero
+      CALL getin_p('ROUGHHEIGHT', roughheight_scal)
+      roughheight(:) = roughheight_scal
+      !
+    ELSE
+      !
+       IF ( z0cdrag_ave ) THEN
+          CALL condveg_z0cdrag(kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, zlev, &
+               &               height, z0, roughheight)
+       ELSE
+          CALL condveg_z0logz(kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, height, &
+               &              z0, roughheight)
+       ENDIF
+      !
+    ENDIF
+    !!
+    !!
+    IF (long_print) WRITE (numout,*) ' condveg_var_init done '
+
+  END SUBROUTINE condveg_var_init
+  !!
+  !! Algorithm:
+  !! - Simply update the emissivity, albedo and roughness fields
+  !!
+  SUBROUTINE condveg_var_update  (ldrestart_read, kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, &
+       & drysoil_frac, zlev, height, deadleaf_cover, emis, albedo, z0, roughheight)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                       :: kjpindex         !! Domain size
+    LOGICAL, INTENT(in)                             :: ldrestart_read   !! Logical for _restart_ file to read
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget            !! Fraction of vegetation types
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: veget_max        !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio    !! Fraction of continental ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: totfrac_nobio    !! Total fraction of continental ice+lakes+...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: drysoil_frac     !! Fraction of visibly Dry soil(between 0 and 1)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)    :: zlev             !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT(in) :: height           !! Vegetation Height (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)     :: deadleaf_cover   !! Fraction of soil covered by dead leaves
+    ! output scalar
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: emis             !! Emissivity
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo           !! Albedo, vis(1) and nir(2)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: z0               !! Roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)   :: roughheight      !! Effective height for roughness
+    !
+    ! local
+    INTEGER(i_std)                                  :: ji, jv
+    !!
+    !! calculs de emis
+    !!
+
+    emis(:) = emis_scal
+    
+    !!
+    !! calculs de albedo
+    !!
+    !
+    IF ( impaze ) THEN
+       !
+       albedo(:,ivis) = albedo_scal(ivis)
+       albedo(:,inir) = albedo_scal(inir)
+       !
+    ELSE
+       !
+       CALL condveg_albcalc (kjpindex,deadleaf_cover,veget,drysoil_frac,albedo)
+       !
+    ENDIF
+    !
+    !!
+    !! Calculs de la rugosite
+    !!
+    
+    IF ( impaze ) THEN
+
+       DO ji = 1, kjpindex
+         z0(ji) = z0_scal
+         roughheight(ji) = roughheight_scal
+      ENDDO
+
+    ELSE
+       !
+       IF ( z0cdrag_ave ) THEN
+          CALL condveg_z0cdrag (kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, zlev, height, &
+               &                z0, roughheight)
+       ELSE
+          CALL condveg_z0logz (kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, height, &
+               &               z0, roughheight)
+       ENDIF
+       !
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' condveg_var_update done '
+
+  END SUBROUTINE condveg_var_update
+
+  !! Algorithm:
+  !! - The snow albedo is updated by the snow within the mesh
+  !! This is done as a function of snow mass, snow age and vegetation type
+  !! The model is described in Chalita 1992
+  !!
+  SUBROUTINE condveg_snow  (ldrestart_read, kjpindex, veget, frac_nobio, totfrac_nobio, &
+                            snow, snow_age, snow_nobio, snow_nobio_age, albedo, albedo_snow, albedo_glob)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                          :: kjpindex         !! Domain size
+    LOGICAL, INTENT(in)                                :: ldrestart_read   !! Logical for _restart_ file to read
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: veget            !! Fraction of vegetation types
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: frac_nobio       !! Fraction of continental ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: totfrac_nobio    !! Total fraction of continental ice+lakes+ ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: snow             !! Snow mass [Kg/m^2] in vegetation
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio       !! Snow mass [Kg/m^2]on ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)        :: snow_age         !! Snow age
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT(in) :: snow_nobio_age   !! Snow age on ice, lakes, ...
+    ! output scalar
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (inout)  :: albedo           !! Albedo
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: albedo_snow      !! Albedo de la neige
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: albedo_glob      !! Mean albedo
+    !
+    ! local declaration
+    INTEGER(i_std)                                  :: ji, jv, jb       !! Loop index
+    REAL(r_std), DIMENSION(kjpindex)                 :: frac_snow_veg    !! Fraction of snow on vegetation
+    REAL(r_std), DIMENSION(kjpindex,nnobio)          :: frac_snow_nobio  !! Fraction of snow on ice, lakes, ...
+    REAL(r_std), DIMENSION(kjpindex)                 :: snowa_veg        !! Total albedo of snow covered area on vegetation
+    REAL(r_std), DIMENSION(kjpindex,nnobio)          :: snowa_nobio      !! albedo of snow covered area on ice, lakes, ...
+    REAL(r_std), DIMENSION(kjpindex)                 :: fraction_veg     !! total vegetation fraction
+    REAL(r_std), DIMENSION(kjpindex)                 :: agefunc_veg      !! age dependency of snow albedo on vegetation
+    REAL(r_std), DIMENSION(kjpindex,nnobio)          :: agefunc_nobio    !! age dependency of snow albedo on ice, lakes, ..;
+    REAL(r_std)                                      :: alb_nobio
+    !
+
+    DO ji = 1, kjpindex
+     albedo_snow(ji) = zero
+     albedo_glob(ji) = zero
+    ENDDO
+
+    IF (ABS(fixed_snow_albedo - undef_sechiba) .GT. EPSILON(undef_sechiba)) THEN
+      snowa_veg(:) = fixed_snow_albedo
+      snowa_nobio(:,:) = fixed_snow_albedo
+    ELSE
+      !
+      ! calculate first age dependence
+      !
+      DO ji = 1, kjpindex
+        agefunc_veg(ji) = EXP(-snow_age(ji)/tcst_snowa)
+      ENDDO
+      !
+      !
+      DO jv = 1, nnobio
+        DO ji = 1, kjpindex
+          agefunc_nobio(ji,jv) = EXP(-snow_nobio_age(ji,jv)/tcst_snowa)
+        ENDDO
+      ENDDO
+      !
+      ! snow albedo on vegetated surfaces
+      !
+      fraction_veg(:) = un - totfrac_nobio(:)
+      snowa_veg(:) = zero
+      DO jv = 1, nvm
+        DO ji = 1, kjpindex
+          IF ( fraction_veg(ji) .GT. min_sechiba ) THEN
+            snowa_veg(ji) = snowa_veg(ji) + &
+              veget(ji,jv)/fraction_veg(ji) * ( snowa_ini(jv)+snowa_dec(jv)*agefunc_veg(ji) )
+          ENDIF
+        ENDDO
+      ENDDO
+      !
+      ! snow albedo on other surfaces
+      !
+      DO jv = 1, nnobio
+        DO ji = 1, kjpindex
+          snowa_nobio(ji,jv) = ( snowa_ini(1) + snowa_dec(1) * agefunc_nobio(ji,jv) ) 
+        ENDDO
+      ENDDO
+    ENDIF
+
+    frac_snow_veg(:) = MIN(MAX(snow(:),zero)/(MAX(snow(:),zero)+snowcri_alb),un)
+    DO jv = 1, nnobio
+      frac_snow_nobio(:,jv) = MIN(MAX(snow_nobio(:,jv),zero)/(MAX(snow_nobio(:,jv),zero)+snowcri_alb),un)
+    ENDDO
+
+
+    DO jb = 1, 2
+      !
+      albedo(:,jb) = ( fraction_veg(:) ) * &
+                         ( (un-frac_snow_veg(:)) * albedo(:,jb) + &
+                           ( frac_snow_veg(:)  ) * snowa_veg(:)    )
+      albedo_snow(:) =  albedo_snow(:) + (fraction_veg(:)) * (frac_snow_veg(:)) * snowa_veg(:)
+      !
+      DO jv = 1, nnobio
+        ! 
+        IF ( jv .EQ. iice ) THEN
+          alb_nobio = alb_ice(jb)
+        ELSE
+          WRITE(numout,*) 'jv=',jv
+          STOP 'DO NOT KNOW ALBEDO OF THIS SURFACE TYPE'
+        ENDIF
+        !
+        albedo(:,jb) = albedo(:,jb) + &
+                       ( frac_nobio(:,jv) ) * &
+                         ( (un-frac_snow_nobio(:,jv)) * alb_nobio + &
+                           ( frac_snow_nobio(:,jv)  ) * snowa_nobio(:,jv)   )
+        albedo_snow(:) = albedo_snow(:) + &
+                         ( frac_nobio(:,jv) ) * ( frac_snow_nobio(:,jv) ) * &
+                           snowa_nobio(:,jv)
+        albedo_glob(:) = albedo_glob(:) + albedo(:,jb)
+        !
+      ENDDO
+      !
+    END DO
+    !
+    DO ji = 1, kjpindex
+      albedo_snow(ji) = (albedo_snow(ji))/2.
+      albedo_glob(ji) = (albedo_glob(ji))/2.
+    ENDDO
+    
+    IF (long_print) WRITE (numout,*) ' condveg_snow done '
+
+  END SUBROUTINE condveg_snow
+  !
+  !
+  !
+  SUBROUTINE condveg_soilalb(nbpt, lalo, neighbours, resolution, contfrac, soilalb_dry,soilalb_wet)
+    !
+    !
+    !   This subroutine should read the soil color maps from the Henderson-Sellers & Wilson database. This data
+    !   is then interpolated to the models resolution and transformed into dry and wet albedos. We have chosen to
+    !  do both these operations at the same time as one can average the albedo but not the color types.
+    !
+    !  We make the assumption in this code that the grid of the data is regular and that it covers the globe. 
+    !  For the model grid we base the calculation of the borders of the grid on the resolution.
+    !
+    !
+    !  0.1 INPUT
+    !
+  INTEGER(i_std), INTENT(in)    :: nbpt                ! Number of points for which the data needs to be interpolated
+  REAL(r_std), INTENT(in)       :: lalo(nbpt,2)        ! Vector of latitude and longitudes (beware of the order !)
+  INTEGER(i_std), INTENT(in)    :: neighbours(nbpt,8)  ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+  REAL(r_std), INTENT(in)       :: resolution(nbpt,2)  ! The size in km of each grid-box in X and Y
+  REAL(r_std), INTENT(in)       :: contfrac(nbpt)     ! Fraction of land in each grid box.
+  REAL(r_std), INTENT(inout)    :: soilalb_dry(nbpt,2) ! albedo for the dry bare soil
+  REAL(r_std), INTENT(inout)    :: soilalb_wet(nbpt,2) ! albedo for the wet bare soil
+
+  !
+  !
+  !  0.3 LOCAL
+  !
+  INTEGER(i_std)    :: nbvmax
+  !
+  CHARACTER(LEN=80) :: filename
+  INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt, ilf, lastjp, nbexp
+  REAL(r_std) :: lev(1), date, dt, coslat, sgn
+  INTEGER(i_std) :: itau(1)
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:)        :: lat_rel, lon_rel, soilcol
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:)        :: sub_area
+  INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+  INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)    :: mask
+  CHARACTER(LEN=30) :: callsign
+  !
+  !   The correspondance table for the soil color numbers and their albedo
+  !
+  INTEGER(i_std), PARAMETER :: classnb = 9
+  !
+  REAL(r_std), DIMENSION(classnb) :: vis_dry = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.27/)
+  REAL(r_std), DIMENSION(classnb) :: nir_dry = (/0.48, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20, 0.55/)  
+  REAL(r_std), DIMENSION(classnb) :: vis_wet = (/0.12, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05, 0.15/)  
+  REAL(r_std), DIMENSION(classnb) :: nir_wet = (/0.24, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10, 0.31/)
+  !   
+  ! Nathalie, introduction d'un albedo moyen, VIS+NIR
+  ! Les valeurs suivantes correspondent a la moyenne des valeurs initiales
+  !  REAL(stnd), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.165, 0.15, 0.135, 0.12, 0.105, 0.09, 0.075, 0.21/)
+  !  REAL(stnd), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.33, 0.30, 0.27, 0.24, 0.21, 0.18, 0.15, 0.43/)
+  ! les valeurs retenues accentuent le contraste entre equateur et Sahara. 
+  ! On diminue aussi l'albedo des deserts (tous sauf Sahara)
+  REAL(r_std), DIMENSION(classnb) :: albsoil_vis = (/0.18, 0.16, 0.16, 0.15, 0.12, 0.105, 0.09, 0.075, 0.25/)
+  REAL(r_std), DIMENSION(classnb) :: albsoil_nir = (/0.36, 0.34, 0.34, 0.33, 0.30, 0.25, 0.20, 0.15, 0.45/)
+  !   
+  LOGICAL                  :: ok_interpol = .FALSE. ! optionnal return of aggregate_2d
+  !   
+  INTEGER                  :: ALLOC_ERR
+  !
+  !
+  !  Needs to be a configurable variable
+  !
+  !
+  !Config Key  = SOILALB_FILE
+  !Config Desc = Name of file from which the bare soil albedo
+  !Config Def  = ../surfmap/soils_param.nc
+  !Config If   = !IMPOSE_AZE
+  !Config Help = The name of the file to be opened to read the soil types from 
+  !Config        which we derive then the bare soil albedos. This file is 1x1 
+  !Config        deg and based on the soil colors defined by Wilson and Henderson-Seller.
+  !
+  filename = '../surfmap/soils_param.nc'
+  CALL getin_p('SOILALB_FILE',filename)
+  !
+  IF (is_root_prc) CALL flininfo(filename,iml, jml, lml, tml, fid)
+  CALL bcast(iml)
+  CALL bcast(jml)
+  CALL bcast(lml)
+  CALL bcast(tml)
+  !
+  ! soils_param.nc file is 1° soit texture file.
+  !
+  ALLOC_ERR=-1
+  ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     PRINT *,"ERROR IN ALLOCATION of lat_rel : ",ALLOC_ERR
+     STOP 
+  ENDIF
+  ALLOC_ERR=-1
+  ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     PRINT *,"ERROR IN ALLOCATION of lon_rel : ",ALLOC_ERR
+     STOP 
+  ENDIF
+  ALLOC_ERR=-1
+  ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     PRINT *,"ERROR IN ALLOCATION of mask : ",ALLOC_ERR
+     STOP 
+  ENDIF
+  ALLOC_ERR=-1
+  ALLOCATE(soilcol(iml,jml), STAT=ALLOC_ERR)
+  IF (ALLOC_ERR/=0) THEN
+     PRINT *,"ERROR IN ALLOCATION of soiltext : ",ALLOC_ERR
+     STOP 
+  ENDIF
+  !
+  IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
+  CALL bcast(lon_rel)
+  CALL bcast(lat_rel)
+  CALL bcast(lev)
+  CALL bcast(itau)
+  CALL bcast(date)
+  CALL bcast(dt)
+  !
+  IF (is_root_prc) CALL flinget(fid, 'soilcolor', iml, jml, lml, tml, 1, 1, soilcol)
+  CALL bcast(soilcol)
+  !
+  IF (is_root_prc) CALL flinclo(fid)
+  !
+  ! Mask of permitted variables.
+  !
+  mask(:,:) = zero
+  DO ip=1,iml
+     DO jp=1,jml
+        IF (soilcol(ip,jp) > min_sechiba) THEN
+           mask(ip,jp) = un
+        ENDIF
+     ENDDO
+  ENDDO
+  !
+  nbvmax = 200
+  !
+  callsign = 'Soil color map'
+  !
+  DO WHILE ( .NOT. ok_interpol )
+     WRITE(numout,*) "Projection arrays for ",callsign," : "
+     WRITE(numout,*) "nbvmax = ",nbvmax
+     !
+     ALLOC_ERR=-1
+     ALLOCATE(sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
+     IF (ALLOC_ERR/=0) THEN
+        PRINT *,"ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
+        STOP 
+     ENDIF
+     sub_area(:,:)=zero
+     ALLOC_ERR=-1
+     ALLOCATE(sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
+     IF (ALLOC_ERR/=0) THEN
+        PRINT *,"ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
+        STOP 
+     ENDIF
+     sub_index(:,:,:)=0
+     !
+     CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
+          &                iml, jml, lon_rel, lat_rel, mask, callsign, &
+          &                nbvmax, sub_index, sub_area, ok_interpol)
+     !
+     IF ( .NOT. ok_interpol ) THEN
+        DEALLOCATE(sub_area)
+        DEALLOCATE(sub_index)
+     ENDIF
+     !
+     nbvmax = nbvmax * 2
+  ENDDO
+  !
+  nbexp = 0
+  !
+  !    Check that we found some points
+  !
+  soilalb_dry(:,:) = zero
+  soilalb_wet(:,:) = zero
+  ! Ajout Nathalie
+  soilalb_moy(:,:) = zero
+  !
+  DO ib=1,nbpt
+     !
+     ! GO through the point we have found
+     !
+     !
+     fopt =  COUNT(sub_area(ib,:) > zero)
+     !
+     IF ( fopt .EQ. 0) THEN
+        nbexp = nbexp + 1
+        soilalb_dry(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
+        soilalb_dry(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
+        soilalb_wet(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
+        soilalb_wet(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
+        ! Ajout Nathalie
+        soilalb_moy(ib,ivis) = SUM(albsoil_vis)/classnb
+        soilalb_moy(ib,inir) = SUM(albsoil_nir)/classnb
+     ELSE
+        sgn = zero
+        !
+        !   Compute the average bare soil albedo parameters
+        !
+        DO ilf = 1,fopt
+           !
+           ip = sub_index(ib,ilf,1)
+           jp = sub_index(ib,ilf,2)
+           !
+           IF ( NINT(soilcol(ip,jp)) .LE. classnb) THEN
+              soilalb_dry(ib,ivis) = soilalb_dry(ib,ivis) + vis_dry(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
+              soilalb_dry(ib,inir) = soilalb_dry(ib,inir) + nir_dry(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
+              soilalb_wet(ib,ivis) = soilalb_wet(ib,ivis) + vis_wet(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
+              soilalb_wet(ib,inir) = soilalb_wet(ib,inir) + nir_wet(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
+              ! Ajout Nathalie
+              soilalb_moy(ib,ivis) = soilalb_moy(ib,ivis) + albsoil_vis(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
+              soilalb_moy(ib,inir) = soilalb_moy(ib,inir) + albsoil_nir(NINT(soilcol(ip,jp))) * sub_area(ib,ilf)
+              sgn = sgn + sub_area(ib,ilf)
+           ELSE
+              WRITE(numout,*) 'The file contains a soil color class which is incompatible with this program'
+              STOP
+           ENDIF
+           !
+        ENDDO
+        !
+        ! Normalize the surface
+        !
+        IF ( sgn .LT. min_sechiba) THEN
+           nbexp = nbexp + 1
+           soilalb_dry(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
+           soilalb_dry(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
+           soilalb_wet(ib,ivis) = (SUM(vis_dry)/classnb + SUM(vis_wet)/classnb)/deux
+           soilalb_wet(ib,inir) = (SUM(nir_dry)/classnb + SUM(nir_wet)/classnb)/deux
+           ! Ajout Nathalie
+           soilalb_moy(ib,ivis) = SUM(albsoil_vis)/classnb
+           soilalb_moy(ib,inir) = SUM(albsoil_nir)/classnb
+        ELSE
+           soilalb_dry(ib,ivis) = soilalb_dry(ib,ivis)/sgn
+           soilalb_dry(ib,inir) = soilalb_dry(ib,inir)/sgn
+           soilalb_wet(ib,ivis) = soilalb_wet(ib,ivis)/sgn
+           soilalb_wet(ib,inir) = soilalb_wet(ib,inir)/sgn
+           ! Ajout Nathalie
+           soilalb_moy(ib,ivis) = soilalb_moy(ib,ivis)/sgn
+           soilalb_moy(ib,inir) = soilalb_moy(ib,inir)/sgn           
+        ENDIF
+        !
+     ENDIF
+     !
+  ENDDO
+  !
+  IF ( nbexp .GT. 0 ) THEN
+     WRITE(numout,*) 'CONDVEG_soilalb : The interpolation of the bare soil albedo had ', nbexp
+     WRITE(numout,*) 'CONDVEG_soilalb : points without data. This are either coastal points or'
+     WRITE(numout,*) 'CONDVEG_soilalb : ice covered land.'
+     WRITE(numout,*) 'CONDVEG_soilalb : The problem was solved by using the average of all soils'
+     WRITE(numout,*) 'CONDVEG_soilalb : in dry and wet conditions'
+  ENDIF
+  !
+  DEALLOCATE (lat_rel)
+  DEALLOCATE (lon_rel)
+  DEALLOCATE (mask)
+  DEALLOCATE (sub_index)
+  DEALLOCATE (sub_area)
+  DEALLOCATE (soilcol)
+  !
+  !
+  RETURN
+  !
+  END SUBROUTINE condveg_soilalb
+  !
+  !
+  !
+  SUBROUTINE condveg_z0logz (kjpindex, veget, veget_max, frac_nobio, totfrac_nobio, height, &
+       &                     z0, roughheight)
+
+    !
+    ! 0. Declarations
+    !
+
+    ! 0.1 Input
+    INTEGER(i_std), INTENT(in)                       :: kjpindex
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget_max
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(in) :: frac_nobio
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)     :: totfrac_nobio
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: height
+    
+    ! 0.2 Output
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)    :: z0
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)    :: roughheight
+    
+    ! 0.3 Local
+    INTEGER(i_std)                                 :: jv
+    REAL(r_std), DIMENSION(kjpindex)                 :: sumveg, ave_height
+    REAL(r_std), DIMENSION(kjpindex)                 :: d_veg, zhdispl
+    REAL(r_std)                                      :: z0_nobio
+    
+    z0(:) = veget(:,1) * LOG(z0_bare)
+    sumveg(:) = veget(:,1)
+    ave_height(:) = zero
+    !
+    DO jv = 2, nvm
+       !
+       IF ( is_tree(jv) ) THEN
+          ! tree trunks influence the atmosphere even when there are no leaves
+          d_veg(:) = veget_max(:,jv)
+       ELSE
+          ! grasses only have an influence if they are really there!
+          d_veg(:) = veget(:,jv)
+       ENDIF
+       !
+       z0(:) = z0(:) + d_veg(:) * &
+            LOG( MAX(height(:,jv)*z0_over_height,z0_bare) )
+       sumveg(:) = sumveg(:) + d_veg(:)
+       !
+       ave_height(:) = ave_height(:) + veget_max(:,jv)*height(:,jv)
+       !
+    ENDDO
+    !
+    WHERE ( sumveg(:) > zero ) z0(:) = z0(:) / sumveg(:)
+    !
+    z0(:) = (un - totfrac_nobio(:)) * z0(:)
+    !
+    DO jv = 1, nnobio
+       !
+       IF ( jv .EQ. iice ) THEN
+          z0_nobio = z0_ice
+       ELSE
+          WRITE(numout,*) 'jv=',jv
+          STOP 'DO NOT KNOW ROUGHNESS OF THIS SURFACE TYPE'
+       ENDIF
+       !
+       z0(:) = z0(:) + frac_nobio(:,jv) * LOG(z0_nobio)
+       !
+    ENDDO
+    !
+    z0(:) = EXP( z0(:) )
+    !
+    ! Temporarily we compute the zero plane displacement height
+    !
+    zhdispl(:) = ave_height(:) * height_displacement
+    !
+    ! In order to get a variable independent of the height of the
+    ! vegetation we compute what we call the effective roughness height.
+    ! This is the height over which the roughness acts. It combines the
+    ! zero plane displacement height and the vegetation height.
+    !
+    roughheight(:) = ave_height(:) - zhdispl(:)
+    !
+  END SUBROUTINE condveg_z0logz
+  !
+  !
+  !
+  SUBROUTINE condveg_z0cdrag (kjpindex,veget,veget_max,frac_nobio,totfrac_nobio,zlev, height, &
+       &                      z0, roughheight)
+    
+    !
+    ! 0. Declarations
+    !
+    
+    ! 0.1 Input
+    INTEGER(i_std), INTENT(in)                       :: kjpindex
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget_max
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(in) :: frac_nobio
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)     :: totfrac_nobio
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)    :: zlev             !! Height of first layer
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: height    
+    
+    ! 0.2 Output
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)    :: z0
+    REAL(r_std), DIMENSION(kjpindex), INTENT(out)    :: roughheight
+    
+    ! 0.3 Local
+    INTEGER(i_std)                                 :: jv
+    REAL(r_std), DIMENSION(kjpindex)                 :: sumveg, ztmp, ave_height
+    REAL(r_std), DIMENSION(kjpindex)                 :: d_veg, zhdispl
+    REAL(r_std)                                      :: z0_nobio
+    !
+    ! The grid average z0 is computed by averaging the neutral drag coefficients.
+    ! This is pretty straight forward except for the reference level which needs
+    ! to be chosen.
+    !
+    ! We need a reference lever high enough above the canopy else we get into
+    ! singularities of the LOG.
+    !
+    ztmp(:) = MAX(10., zlev(:))
+    !
+    z0(:) = veget(:,1) * (ct_karman/LOG(ztmp(:)/z0_bare))**2
+    sumveg(:) = veget(:,1)
+    ave_height(:) = zero
+    !
+    DO jv = 2, nvm
+       !
+       IF ( is_tree(jv) ) THEN
+          ! tree trunks influence the atmosphere even when there are no leaves
+          d_veg(:) = veget_max(:,jv)
+       ELSE
+          ! grasses only have an influence if they are really there!
+          d_veg(:) = veget(:,jv)
+       ENDIF
+       !
+       z0(:) = z0(:) + d_veg(:) * (ct_karman/LOG(ztmp(:)/MAX(height(:,jv)*z0_over_height,z0_bare)))**2
+       sumveg(:) = sumveg(:) + d_veg(:)
+       !
+       ave_height(:) = ave_height(:) + veget_max(:,jv)*height(:,jv)
+       !
+    ENDDO
+    !
+    WHERE ( sumveg(:) .GT. zero ) z0(:) = z0(:) / sumveg(:)
+    !
+    z0(:) = (un - totfrac_nobio(:)) * z0(:)
+    !
+    DO jv = 1, nnobio
+       !
+       IF ( jv .EQ. iice ) THEN
+          z0_nobio = z0_ice
+       ELSE
+          WRITE(numout,*) 'jv=',jv
+          STOP 'DO NOT KNOW ROUGHNESS OF THIS SURFACE TYPE'
+       ENDIF
+       !
+       z0(:) = z0(:) + frac_nobio(:,jv) * (ct_karman/LOG(ztmp(:)/z0_nobio))**2
+       !
+    ENDDO
+    !
+    z0(:) = ztmp(:) / EXP(ct_karman/SQRT(z0(:)))
+    !
+    ! Temporarily we compute the zero plane displacement height
+    !
+    zhdispl(:) = ave_height(:) * height_displacement
+    !
+    ! In order to get a variable independent of the height of the
+    ! vegetation we compute what we call the effective roughness height.
+    ! This is the height over which the roughness acts. It combines the
+    ! zero plane displacement height and the vegetation height.
+    !
+    roughheight(:) = ave_height(:) - zhdispl(:)
+    !
+  END SUBROUTINE condveg_z0cdrag
+  !
+  !
+  !
+  SUBROUTINE condveg_albcalc (kjpindex,deadleaf_cover,veget,drysoil_frac,albedo)
+
+    !
+    ! 0. Declarations
+    !
+
+    ! 0.1 Input
+    INTEGER(i_std), INTENT(in)                       :: kjpindex        !! Domain size
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)     :: deadleaf_cover  !! Fraction of soil covered by dead leaves
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in) :: veget           !! Fraction of vegetation types
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)     :: drysoil_frac    !! Fraction of visibly Dry soil(between 0 and 1)
+    
+    ! 0.2 Output
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out) :: albedo  !! Albedo, vis(1) and nir(2)
+    ! 0.3 Local
+!    REAL(r_std),DIMENSION (kjpindex)                 :: alb_bare
+    REAL(r_std),DIMENSION (nvm,2)                    :: alb_leaf_tmp
+    INTEGER(i_std)                                   :: ks, jv
+    !
+    alb_leaf_tmp(:,1) = alb_leaf(1:nvm)
+    alb_leaf_tmp(:,2) = alb_leaf(nvm+1:2*nvm)
+    !
+    !
+    DO ks = 1, 2
+       !
+       IF ( alb_bare_model ) THEN
+          alb_bare(:,ks) = soilalb_wet(:,ks) + drysoil_frac(:) * (soilalb_dry(:,ks) -  soilalb_wet(:,ks))
+       ELSE
+          ! Nouvelle formulation Nathalie, sans dependance en drysoil_frac.
+          alb_bare(:,ks) = soilalb_moy(:,ks)
+       ENDIF
+       !
+       ! Correction Nathalie le 12 Avril 2006 - suppression de la dependance en deadleaf_cover
+       !albedo(:,ks) = veget(:,1) * ( (un-deadleaf_cover(:))*alb_bare(:) + &
+       !                              deadleaf_cover(:)*alb_deadleaf(ks)    )
+       albedo(:,ks) = veget(:,1) * alb_bare(:,ks)
+
+       ! vegetation
+       alb_veget(:,ks) = zero
+       DO jv = 2, nvm
+          albedo(:,ks) = albedo(:,ks) + veget(:,jv)*alb_leaf_tmp(jv,ks)
+          alb_veget(:,ks) = alb_veget(:,ks) + veget(:,jv)*alb_leaf_tmp(jv,ks)
+       ENDDO
+       !
+    ENDDO
+    
+  END SUBROUTINE condveg_albcalc
+
+END MODULE condveg
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/diffuco.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/diffuco.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/diffuco.f90	(revision 55)
@@ -0,0 +1,1754 @@
+!!
+!! This module computes diffusion coefficients for continental points.
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!! 
+MODULE diffuco
+
+  ! modules used :
+  USE constantes
+  USE constantes_veg
+  USE sechiba_io
+  USE ioipsl
+  USE constantes_co2
+  USE parallel
+!  USE WRITE_FIELD_p
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! diffuco_main only
+  PRIVATE
+  PUBLIC :: diffuco_main,diffuco_clear
+
+  !
+  ! variables used inside diffuco module : declaration and initialisation
+  !
+  INTEGER(i_std), PARAMETER                         :: nlai = 20
+  LOGICAL, SAVE                                     :: l_first_diffuco = .TRUE.  !! Initialisation has to be done one time
+  CHARACTER(LEN=80)                                 :: var_name                  !! To store variables names for I/O
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: leaf_ci                   !! intercellular CO2 concentration (ppm)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: rstruct                   !! architectural resistance
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: raero                     !! Aerodynamic resistance
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: qsatt                     !! Surface saturated humidity
+  !! Nathalie le 28 mars 2006 - sur proposition de Fred Hourdin, ajout
+  !! d'un potentiometre pour regler la resistance de la vegetation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      ::  rveg_pft
+  ! MM
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: wind                     !! Wind norm
+
+CONTAINS
+
+  !! 
+  !! Main routine for *diffuco* module.
+  !! - called only one time for initialisation
+  !! - called every time step
+  !! - called one more time at last time step for writing _restart_ file
+  !!
+  !! Algorithm:
+  !! - call diffuco_aero for aerodynamic transfer coeficient
+  !! - call diffuco_snow for partial beta coefficient : sublimation
+  !! - call diffuco_inter for partial beta coefficient : interception for each type of vegetation
+  !! - call diffuco_bare for partial beta coefficient : bare soil
+  !! - call diffuco_trans for partial beta coefficient : transpiration for each type of vegetation
+  !! - call diffuco_comb for alpha and beta coefficient
+  !!
+  !! @call diffuco_aero
+  !! @call diffuco_snow
+  !! @call diffuco_inter
+  !! @call diffuco_bare
+  !! @call diffuco_trans
+  !! @call diffuco_comb
+  !!
+  SUBROUTINE diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+!     & zlev, z0, roughheight, temp_sol, temp_air, rau, q_cdrag, qsurf, qair, pb, &
+     & zlev, z0, roughheight, temp_sol, temp_air, rau, q_cdrag, qsurf, qair, q2m, t2m, pb, &
+     & rsol, evap_bare_lim, evapot, snow, frac_nobio, snow_nobio, totfrac_nobio, &
+     & swnet, swdown, ccanopy, humrel, veget, veget_max, lai, qsintveg, qsintmax, assim_param, &
+     & vbeta , valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
+
+    ! interface description:
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                         :: kjit             !! Time step number 
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size
+    INTEGER(i_std),INTENT (in)                         :: rest_id          !! _Restart_ file identifier
+    INTEGER(i_std),INTENT (in)                         :: hist_id          !! _History_ file identifier
+    INTEGER(i_std),INTENT (in)                         :: hist2_id          !! _History_ file 2 identifier
+    REAL(r_std), INTENT (in)                           :: dtradia          !! Time step in seconds
+    LOGICAL, INTENT(in)                               :: ldrestart_read   !! Logical for restart file to read
+    LOGICAL, INTENT(in)                               :: ldrestart_write  !! Logical for restart file to write
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)     :: index            !! Indeces of the points on the map
+    INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in) :: indexveg         !! Indeces of the points on the 3D map
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: u                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: v                !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: zlev             !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: z0               !! Surface roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: roughheight      !! Effective height for roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol         !! Skin temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_air         !! Lowest level temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: rau              !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: qsurf            !! near surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: qair             !! Lowest level specific humidity
+! Ajout Nathalie - declaration q2m
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: q2m              !! 2m specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: t2m              !! 2m air temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow             !! Snow mass
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: pb               !! Surface level pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: rsol             !! Bare soil evaporation resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evap_bare_lim    !! Beta factor for bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot           !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio     !! Fraction of ice,lakes,cities,...
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio     !! Snow on ice,lakes,cities,...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: totfrac_nobio    !! Total fraction of ice+lakes+cities+...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swnet            !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swdown           !! Down-welling surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: ccanopy          !! CO2 concentration inside the canopy
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget            !! Fraction of vegetation type 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max        !! Max. fraction of vegetation type (LAI->infty)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: lai              !! Leaf area index
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintveg         !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintmax         !! Maximum water on vegetation for interception
+    REAL(r_std),DIMENSION (kjpindex,nvm,npco2), INTENT (in):: assim_param  !! min+max+opt temps, vcmax, vjmax for photosynthesis
+    ! modified fields 
+    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (inout) :: humrel        !! Moisture stress
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: q_cdrag          !! Surface drag ! Aerodynamic conductance
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vbeta            !! Total beta coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: valpha           !! Total alpha coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vbeta1           !! Beta for sublimation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vbeta4           !! Beta for bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbetaco2         !! STOMATE: Beta for CO2
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta2           !! Beta for interception loss
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vbeta3           !! Beta for transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: rveget           !! Surface resistance for the vegetatuon
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: cimean           !! STOMATE: mean intercellular ci (see enerbil)
+    ! Local
+    ! AJout Nathalie - Juin 2006
+    !! Beta for fraction of wetted foliage that will transpire
+    REAL(r_std),DIMENSION (kjpindex,nvm)               :: vbeta23          
+
+    INTEGER(i_std)                                    :: ilai
+    CHARACTER(LEN=4)                                  :: laistring
+
+    ! do initialisation if needed
+
+    IF (l_first_diffuco) THEN
+
+        !Config Key  = CDRAG_FROM_GCM
+        !Config Desc = Keep cdrag coefficient from gcm.
+        !Config Def  = TRUE if q_cdrag on initialization is non zero
+        !Config Help = Set to .TRUE. if you want q_cdrag coming from GCM.
+        !Congig        Keep cdrag coefficient from gcm for latent and sensible heat fluxes.
+        IF ( ABS(MAXVAL(q_cdrag)) .LE. EPSILON(q_cdrag)) THEN
+           ldq_cdrag_from_gcm = .FALSE.
+        ELSE
+           ldq_cdrag_from_gcm = .TRUE.
+        ENDIF
+!MM q_cdrag is always 0 on initialization ??
+        CALL getin_p('CDRAG_from_GCM', ldq_cdrag_from_gcm)
+        
+        WRITE(numout,*) "ldq_cdrag_from_gcm = ",ldq_cdrag_from_gcm
+
+        IF (long_print) WRITE (numout,*) ' call diffuco_init '
+
+        ! If cdrag is 
+        CALL diffuco_init(kjit, ldrestart_read, kjpindex, index, rest_id, q_cdrag)
+
+        RETURN
+
+    ENDIF
+    !
+    ! prepares restart file for the next simulation
+    !
+    IF (ldrestart_write) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to complete restart file with DIFFUCO variables '
+
+        var_name= 'rstruct'
+	CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, rstruct, 'scatter',  nbp_glo, index_g)
+  
+        var_name= 'raero'
+	CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, raero, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'qsatt'
+	CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, qsatt, 'scatter',  nbp_glo, index_g)
+  
+        ! the following variable is written only if CO2 was calculated
+        IF ( control%ok_co2 ) THEN
+
+          DO ilai = 1, nlai
+  
+            ! variable name is somewhat complicated as ioipsl does not allow 3d variables for the moment...
+            write(laistring,'(i4)') ilai
+            laistring=ADJUSTL(laistring)
+            var_name='leaf_ci_'//laistring(1:LEN_TRIM(laistring))
+  
+            CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, leaf_ci(:,:,ilai), 'scatter',  nbp_glo, index_g)
+  
+          ENDDO
+
+        ENDIF
+  
+        IF (.NOT.ldq_cdrag_from_gcm) THEN
+           var_name= 'cdrag'
+           CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, q_cdrag, 'scatter',  nbp_glo, index_g)
+        ENDIF
+  
+      RETURN
+  
+    END IF
+    ! MM
+    wind(:) = SQRT (u(:)*u(:) + v(:)*v(:))
+
+    !
+    ! calculs des differents coefficients
+    !
+    IF (.NOT.ldq_cdrag_from_gcm) THEN
+       CALL diffuco_aero (kjpindex, kjit, u, v, zlev, z0, roughheight, veget_max, temp_sol, temp_air, &
+            &             qsurf, qair, q_cdrag)
+    ENDIF
+    CALL diffuco_raerod (kjpindex, u, v, q_cdrag, raero)
+
+    !
+    ! An estimation of the satturated humidity at the surface
+    !
+
+    CALL qsatcalc (kjpindex, temp_sol, pb, qsatt)
+
+    !
+    ! beta coefficient for sublimation
+    !
+
+    CALL diffuco_snow (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, &
+         & snow, frac_nobio, totfrac_nobio, snow_nobio, vbeta1)
+
+    !
+    ! beta coefficient for interception
+    !
+
+    ! Correction Nathalie - Juin 2006 - introduction d'un terme vbeta23
+    !CALL diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
+    !   & qsintveg, qsintmax, rstruct, vbeta2) 
+    CALL diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
+       & qsintveg, qsintmax, rstruct, vbeta2, vbeta23) 
+
+    !
+    ! beta coefficient for bare soil
+    !
+    CALL diffuco_bare (kjpindex, dtradia, u, v, q_cdrag, rsol, evap_bare_lim, evapot, humrel, veget, vbeta4) 
+
+    !
+    ! beta coefficient for transpiration
+    !
+
+    IF ( control%ok_co2 ) THEN
+
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+      ! Correction Nathalie - Juin 2006 - introduction d'un terme vbeta23
+      !CALL diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+      !                        assim_param, ccanopy, &
+      !                        veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)
+
+      CALL diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, q2m, t2m, rau, u, v, q_cdrag, humrel, &
+                              assim_param, ccanopy, &
+                              veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)
+
+    ELSE
+
+      ! Correction Nathalie - Juin 2006 - introduction d'un terme vbeta23
+      !CALL diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+      !                    veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)
+
+      CALL diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+                          veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)
+
+    ENDIF
+
+    !
+    ! combination of coefficient : alpha and beta coefficient
+    !
+
+    ! Ajout qsintmax dans les arguments de la routine.... Nathalie / le 13-03-2006
+    CALL diffuco_comb (kjpindex, dtradia, humrel, rau, u, v, q_cdrag, pb, qair, temp_sol, temp_air, snow, &
+       & veget, lai, vbeta1, vbeta2, vbeta3, vbeta4, valpha, vbeta, qsintmax)    
+
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite(hist_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'raero', kjit, raero, kjpindex, index)
+       ! Ajouts Nathalie - novembre 2006
+       CALL histwrite(hist_id, 'cdrag', kjit, q_cdrag, kjpindex, index)
+       CALL histwrite(hist_id, 'Wind', kjit, wind, kjpindex, index)
+       ! Fin ajouts Nathalie
+!MM
+       CALL histwrite(hist_id, 'qsatt', kjit, qsatt, kjpindex, index)
+
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'rstruct', kjit, rstruct, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'raero', kjit, raero, kjpindex, index)
+          CALL histwrite(hist2_id, 'cdrag', kjit, q_cdrag, kjpindex, index)
+          CALL histwrite(hist2_id, 'Wind', kjit, wind, kjpindex, index)
+          CALL histwrite(hist2_id, 'qsatt', kjit, qsatt, kjpindex, index)
+       ENDIF
+    ELSE
+
+    ENDIF
+    !
+    !
+    IF (long_print) WRITE (numout,*) ' diffuco_main done '
+
+  END SUBROUTINE diffuco_main
+
+  !! Algorithm:
+  !! - dynamic allocation for local array 
+  !!
+  SUBROUTINE diffuco_init(kjit, ldrestart_read, kjpindex, index, rest_id, q_cdrag)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                     :: kjit               !! Time step number 
+    LOGICAL,INTENT (in)                            :: ldrestart_read     !! Logical for restart file to read
+    INTEGER(i_std), INTENT (in)                     :: kjpindex           !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in):: index              !! Indeces of the points on the map
+    INTEGER(i_std), INTENT (in)                     :: rest_id            !! _Restart_ file identifier 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: q_cdrag          !! Surface drag
+    ! input fields
+    ! output scalar
+    ! output fields
+
+    ! local declaration
+    INTEGER(i_std)                  :: ier, jv
+    INTEGER(i_std)                  :: ilai
+    CHARACTER(LEN=4)                :: laistring
+    REAL(r_std),DIMENSION (kjpindex)   :: temp
+
+    !
+    ! initialisation
+    !
+    IF (l_first_diffuco) THEN 
+        l_first_diffuco=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_diffuco false . we stop '
+        STOP 'diffuco_init'
+    ENDIF
+
+    ! allocate only if CO2 is calculated
+    IF ( control%ok_co2 ) THEN
+
+      ALLOCATE (leaf_ci(kjpindex,nvm,nlai),stat=ier)
+      IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in leaf_ci allocation. We stop. We need kjpindex*nvm*nlai words = ',&
+            kjpindex*nvm*nlai
+          STOP 'diffuco_init'
+      END IF
+
+    ENDIF
+
+    ALLOCATE (rstruct(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in rstruct allocation. We stop. We need kjpindex x nvm words = ' ,kjpindex,' x ' ,nvm,&
+           & ' = ',kjpindex*nvm
+        STOP 'diffuco_init'
+    END IF
+    ALLOCATE (raero(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in raero allocation. We stop. We need kjpindex x nvm words = ', kjpindex
+        STOP 'diffuco_init'
+    END IF
+
+    ALLOCATE (qsatt(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in qsatt allocation. We stop. We need kjpindex x nvm words = ', kjpindex
+        STOP 'diffuco_init'
+    END IF
+
+    ALLOCATE (wind(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in wind allocation. We stop. We need kjpindex x nvm words = ', kjpindex
+        STOP 'diffuco_init'
+    END IF
+
+    IF (ldrestart_read) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to read a restart file for DIFFUCO variables'
+
+        var_name='rstruct'
+        CALL ioconf_setatt('UNITS', 's/m')
+        CALL ioconf_setatt('LONG_NAME','Structural resistance')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., rstruct, "gather", nbp_glo, index_g)
+        !
+        IF ( MINVAL(rstruct) .EQ. MAXVAL(rstruct) .AND.  MAXVAL(rstruct) .EQ. val_exp ) THEN
+        !
+           DO jv = 1, nvm
+              rstruct(:,jv) = rstruct_const(jv)
+           ENDDO
+
+        ENDIF
+
+        var_name='raero' ;
+        CALL ioconf_setatt('UNITS', 's/m')
+        CALL ioconf_setatt('LONG_NAME','Aerodynamic resistance')
+        IF ( ok_var(var_name) ) THEN
+           CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp, "gather", nbp_glo, index_g)
+           IF (MINVAL(temp) < MAXVAL(temp) .OR. MAXVAL(temp) .NE. val_exp) THEN
+              raero(:) = temp(:)
+           ENDIF
+        ENDIF
+        !
+        var_name='qsatt' ;
+        CALL ioconf_setatt('UNITS', 'g/g')
+        CALL ioconf_setatt('LONG_NAME','Surface saturated humidity')
+        IF ( ok_var(var_name) ) THEN
+           CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp, "gather", nbp_glo, index_g)
+           IF (MINVAL(temp) < MAXVAL(temp) .OR. MAXVAL(temp) .NE. val_exp) THEN
+              qsatt(:) = temp(:)
+           ENDIF
+        ENDIF
+
+        ! the following variable is read only if CO2 is calculated
+        IF ( control%ok_co2 ) THEN
+
+           CALL ioconf_setatt('UNITS', 'ppm')
+           CALL ioconf_setatt('LONG_NAME','Leaf CO2')
+
+           DO ilai = 1, nlai
+
+              ! variable name is somewhat complicated as ioipsl does not allow 3d variables for the moment...
+              write(laistring,'(i4)') ilai
+              laistring=ADJUSTL(laistring)
+              var_name='leaf_ci_'//laistring(1:LEN_TRIM(laistring))
+              
+              CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE.,leaf_ci(:,:,ilai), "gather", nbp_glo, index_g)
+              
+           ENDDO
+           !
+           !Config Key  = DIFFUCO_LEAFCI
+           !Config Desc = Initial leaf CO2 level if not found in restart
+           !Config Def  = 233.
+           !Config Help = The initial value of leaf_ci if its value is not found
+           !Config        in the restart file. This should only be used if the model is
+           !Config        started without a restart file.
+           !
+           CALL setvar_p (leaf_ci, val_exp,'DIFFUCO_LEAFCI', 233._r_std)
+        ENDIF
+        !
+        IF (.NOT.ldq_cdrag_from_gcm) THEN
+           var_name= 'cdrag'
+           CALL ioconf_setatt('LONG_NAME','Drag coefficient for LE and SH')
+           CALL ioconf_setatt('UNITS', '-')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp) < MAXVAL(temp) .OR. MAXVAL(temp) .NE. val_exp) THEN
+                 q_cdrag(:) = temp(:)
+              ENDIF
+           ENDIF
+           
+        ENDIF
+        
+    ENDIF
+
+    !
+    ! Ajouts Nathalie - le 28 Mars 2006 - sur conseils Fred Hourdin
+    !
+    ALLOCATE (rveg_pft(nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) &
+            ' error in rveg_pft allocation. We stop. We need nvm words = ', nvm
+       STOP 'diffuco_init'
+    END IF
+    !
+    !Config Key  = RVEG_PFT
+    !Config Desc = Artificial parameter to increase or decrease canopy resistance.
+    !Config Def  = 1.
+    !Config Help = This parameter is set by PFT.
+    rveg_pft(:) = un
+    CALL getin_p('RVEG_PFT', rveg_pft)
+
+    WRITE(numout,*) 'DANS DIFFUCO_INIT , RVEG_PFT=',rveg_pft
+
+    IF (long_print) WRITE (numout,*) ' diffuco_init done '
+
+  END SUBROUTINE diffuco_init
+  SUBROUTINE diffuco_clear()
+
+         l_first_diffuco=.TRUE.
+
+      IF (ALLOCATED (leaf_ci)) DEALLOCATE (leaf_ci)
+      IF (ALLOCATED (rstruct)) DEALLOCATE (rstruct)
+      IF (ALLOCATED (raero)) DEALLOCATE (raero)
+      IF (ALLOCATED (rveg_pft)) DEALLOCATE (rveg_pft)
+ 
+  END SUBROUTINE diffuco_clear
+
+  !! This routine computes aerothermic coefficient if required
+  !! see logical *ldq_cdrag_from_gcm*
+  !!
+  SUBROUTINE diffuco_aero (kjpindex, kjit, u, v, zlev, z0, roughheight, veget_max, temp_sol, temp_air, &
+       &                   qsurf, qair, q_cdrag)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex, kjit         !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: zlev             !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: z0               !! Surface roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: roughheight      !! Effective roughness height
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget_max        !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol         !! Skin temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_air         !! Lowest level temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qsurf            !! near surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair             !! Lowest level specific humidity
+
+    ! output scalar
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: q_cdrag          !! Surface drag ! Aerodynamic conductance
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std)                                    :: speed, zg, zdphi, ztvd, ztvs, zdu2
+    REAL(r_std)                                    :: zri, cd_neut, zscf, cd_tmp
+
+    ! initialisation
+
+    ! test if we have to work with q_cdrag or to calcul it
+
+    DO ji=1,kjpindex
+       !
+       ! 1. computes wind speed
+       !
+       speed = wind(ji)
+       !
+       ! 2. computes geopotentiel
+       !
+       zg = zlev(ji) * cte_grav
+       zdphi = zg/cp_air
+       !
+       ! 3. virtual air temperature at the surface
+       !
+       ztvd = (temp_air(ji) + zdphi / (un + rvtmp2 * qair(ji))) * (un + retv * qair(ji)) 
+       !
+       ! 4. virtual surface temperature
+       !
+       ztvs = temp_sol(ji) * (un + retv * qsurf(ji))
+       !
+       ! 5. squared wind shear
+       !
+       zdu2 = MAX(cepdu2,speed**2)
+       !
+       ! 6. Richardson number
+       !
+       zri = zg * (ztvd - ztvs) / (zdu2 * ztvd)
+       zri = MAX(MIN(zri,5.),-5.)
+       !
+       ! 7. Computing the drag coefficient
+       !    We add the add the height of the vegetation to the level height to take into account
+       !    that the level seen by the vegetation is actually the top of the vegetation. Then we 
+       !    we can subtract the displacement height.
+       !
+       cd_neut = (ct_karman / LOG( (zlev(ji) + roughheight(ji)) / z0(ji) )) ** 2 
+       !
+       ! 7.1 Stable case
+       !
+       IF (zri .GE. zero) THEN
+          zscf = SQRT(un + cd * ABS(zri))
+          cd_tmp=cd_neut/(un + trois * cb * zri * zscf)
+       ELSE
+          !
+          ! 7.2 Unstable case
+          !
+          zscf = un / (un + trois * cb * cc * cd_neut * SQRT(ABS(zri) * &
+               & ((zlev(ji) + roughheight(ji)) / z0(ji))))
+          cd_tmp=cd_neut * (un - trois * cb * zri * zscf)
+       ENDIF
+       
+       ! dont let it go to low else the surface uncouples
+       q_cdrag(ji) = MAX(cd_tmp, 1.e-4/MAX(speed,min_wind))
+!!
+!!        In some situations it might be useful to give an upper limit on the cdrag as well. 
+!!        The line here should then be uncommented.
+!!          q_cdrag(ji) = MIN(q_cdrag(ji), 0.5/MAX(speed,min_wind))
+
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' not ldqcdrag_from_gcm : diffuco_aero done '
+
+  END SUBROUTINE diffuco_aero
+
+  !! This routine computes partial beta coefficient : snow sublimation 
+  !!
+  SUBROUTINE diffuco_snow (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, &
+       & snow, frac_nobio, totfrac_nobio, snow_nobio, vbeta1)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex   !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia    !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair       !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qsatt      !! Surface saturated humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau        !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u          !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v          !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag    !! Surface drag
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: snow       !! Snow mass
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in)     :: frac_nobio !! Fraction of ice,lakes,cities,...
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in)     :: snow_nobio !! Snow on ice,lakes,cities,...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: totfrac_nobio!! Total fraction of ice+lakes+cities+...
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vbeta1     !! Beta for sublimation
+
+    ! local declaration
+    REAL(r_std)                                              :: subtest, zrapp, speed, vbeta1_add
+    INTEGER(i_std)                                          :: ji, jv
+
+    !
+    ! 1. beta coefficient for sublimation for snow on vegetation
+    !
+    DO ji=1,kjpindex
+       ! Fraction of mesh that can sublimate snow
+       vbeta1(ji) = (un - totfrac_nobio(ji)) * MAX( MIN(snow(ji)/snowcri,un), zero)
+       !
+       ! -- Limitation of sublimation in case of snow amounts smaller than
+       !    the atmospheric demande. 
+       !
+       speed = MAX(min_wind, wind(ji))
+       !
+       subtest = dtradia * vbeta1(ji) * speed * q_cdrag(ji) * rau(ji) * &
+               & ( qsatt(ji) - qair(ji) )
+       !  
+       IF ( subtest .GT. zero ) THEN
+          zrapp = snow(ji) / subtest
+          IF ( zrapp .LT. un ) THEN
+             vbeta1(ji) = vbeta1(ji) * zrapp
+          ENDIF
+       ENDIF
+       !
+    END DO
+
+    !
+    ! 2. add beta coefficient for other surface types.
+    !
+    DO jv = 1, nnobio
+!!$      !
+!!$      IF ( jv .EQ. iice ) THEN
+!!$        !
+!!$        !  Land ice is of course a particular case
+!!$        !
+!!$        DO ji=1,kjpindex
+!!$          vbeta1(ji) = vbeta1(ji) + frac_nobio(ji,jv)
+!!$        ENDDO
+!!$        !
+!!$      ELSE
+        !
+        DO ji=1,kjpindex
+           !
+           vbeta1_add = frac_nobio(ji,jv) * MAX( MIN(snow_nobio(ji,jv)/snowcri,un), zero)
+           !
+           ! -- Limitation of sublimation in case of snow amounts smaller than
+           !    the atmospheric demand. 
+           !
+           speed = MAX(min_wind, wind(ji))
+           !
+           subtest = dtradia * vbeta1_add * speed * q_cdrag(ji) * rau(ji) * &
+                & ( qsatt(ji) - qair(ji) )
+           !  
+           IF ( subtest .GT. zero ) THEN
+              zrapp = snow_nobio(ji,jv) / subtest
+              IF ( zrapp .LT. un ) THEN
+                 vbeta1_add = vbeta1_add * zrapp
+              ENDIF
+           ENDIF
+           !
+           vbeta1(ji) = vbeta1(ji) + vbeta1_add
+           !
+        ENDDO
+!!$        !
+!!$      ENDIF
+      !
+    ENDDO
+
+    IF (long_print) WRITE (numout,*) ' diffuco_snow done '
+
+  END SUBROUTINE diffuco_snow
+
+  !! This routine computes partial beta coefficient : interception for each type of vegetation
+  !!
+  ! Nathalie - Juin 2006 - Introduction de vbeta23
+  !SUBROUTINE diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
+  !   & qsintveg, qsintmax, rstruct, vbeta2)
+  SUBROUTINE diffuco_inter (kjpindex, dtradia, qair, qsatt, rau, u, v, q_cdrag, veget, &
+     & qsintveg, qsintmax, rstruct, vbeta2, vbeta23)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex   !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia    !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair       !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qsatt      !! Surface saturated humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau        !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u          !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v          !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag    !! Surface drag
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget      !! vegetation fraction for each type
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintveg   !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintmax   !! Maximum water on vegetation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: rstruct    !! STOMATE: architectural resistance
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbeta2     !! Beta for interception loss
+    ! AJout Nathalie - Juin 2006
+    !! Beta for fraction of wetted foliage that will transpire
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbeta23    
+    ! Fin ajout Nathalie
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std)                                    :: zqsvegrap, ziltest, zrapp, speed
+
+    !
+    ! Correction Nathalie - Initialisation des vbeta2x
+    vbeta2(:,:) = zero
+    ! Ajout Nathalie - Juin 2006
+    vbeta23(:,:) = zero
+    ! Fin ajout Nathalie
+    !
+    DO jv = 1,nvm
+
+      !
+      ! 1. beta coefficient for vegetation interception 
+      !
+
+      DO ji=1,kjpindex
+
+        IF (veget(ji,jv) .GT. min_sechiba .AND. qsintveg(ji,jv) .GT. zero ) THEN
+
+            zqsvegrap = zero
+            IF (qsintmax(ji,jv) .GT. min_sechiba ) THEN
+                zqsvegrap = MAX(zero, qsintveg(ji,jv) / qsintmax(ji,jv))
+            END IF
+            !
+            speed = MAX(min_wind, wind(ji))
+            !  -- Interception loss: IL
+            vbeta2(ji,jv) = veget(ji,jv) * zqsvegrap * (un / (un + speed * q_cdrag(ji) * rstruct(ji,jv)))
+
+            !
+            !  -- Limitation of IL by the water stored on the leaf. 
+            !     A first approximation of IL is obtained with the old values of
+            !     qair and qsol_sat: function of temp-sol and pb. (see call of qsatcalc)
+            !
+            ziltest = dtradia * vbeta2(ji,jv) * speed * q_cdrag(ji) * rau(ji) * &
+               & ( qsatt(ji) - qair(ji) )
+            IF ( ziltest .GT. zero ) THEN
+                zrapp = qsintveg(ji,jv) / ziltest
+                IF ( zrapp .LT. un ) THEN
+                   ! Ajout Nathalie - Juin 2006
+                    vbeta23(ji,jv) = MAX(vbeta2(ji,jv) - vbeta2(ji,jv) * zrapp, zero)
+                    ! Fin ajout Nathalie
+                    vbeta2(ji,jv) = vbeta2(ji,jv) * zrapp
+                ENDIF
+            ENDIF
+        END IF
+
+      END DO
+
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' diffuco_inter done '
+
+  END SUBROUTINE diffuco_inter
+
+  !! This routine computes partial beta coefficient : bare soil
+  !!
+  SUBROUTINE diffuco_bare (kjpindex, dtradia, u, v, q_cdrag, rsol, evap_bare_lim, evapot, humrel, veget, vbeta4)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex   !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia    !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u          !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v          !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag    !! Surface drag
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rsol       !! resistance for bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: evap_bare_lim !! Beta factor for bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: evapot     !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: humrel     !! Soil moisture stress
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget      !! Type of vegetation fraction
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vbeta4     !! Beta for bare soil evaporation
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std)                                    :: speed
+
+    IF ( .NOT. control%hydrol_cwrr ) THEN
+       DO ji = 1, kjpindex
+          !
+          vbeta4(ji) = zero
+          !     
+          ! 1.   Soil resistance and beta for bare soil
+          !      note: veget (  ,1) contains the fraction of bare soil
+          !            see hydrol module
+          !
+          IF (veget(ji,1) .GE. min_sechiba) THEN
+             !
+             speed = MAX(min_wind, wind(ji))
+             ! 
+             ! Correction Nathalie de Noblet - le 27 Mars 2006
+             ! Selon recommandation de Frederic Hourdin: supprimer humrel dans formulation vbeta4
+             !vbeta4(ji) = veget(ji,1) *humrel(ji,1)* (un / (un + speed * q_cdrag(ji) * rsol(ji)))
+             ! Nathalie - le 28 mars 2006 - vbeta4 n'etait pas calcule en fonction de
+             ! rsol mais de rsol_cste * hdry! Dans ce cas inutile de calculer rsol(ji)!!
+             vbeta4(ji) = veget(ji,1) * (un / (un + speed * q_cdrag(ji) * rsol(ji)))
+             !
+          ENDIF
+          !
+       END DO
+    ELSE
+       DO ji = 1, kjpindex
+          vbeta4(ji) = evap_bare_lim(ji)
+       END DO
+    ENDIF
+    
+    IF (long_print) WRITE (numout,*) ' diffuco_bare done '
+    
+  END SUBROUTINE diffuco_bare
+
+  !! This routine computes partial beta coefficient : transpiration for each type of vegetation
+  !!
+  ! Nathalie - Juin 2006 - introduction de vbeta23
+  !SUBROUTINE diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+  !                          veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)  
+  SUBROUTINE diffuco_trans (kjpindex, dtradia, swnet, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+                            veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)  
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia          !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet            !! Short wave net flux in
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_air         !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb               !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair             !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau              !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag          !! Surface drag
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: humrel           !! Soil moisture stress
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget            !! Type of vegetation fraction
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget_max        !! Max. vegetation fraction (LAI -> infty)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: lai              !! Leaf area index
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintveg         !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintmax         !! Maximum water on vegetation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: rstruct          !! STOMATE
+    ! AJout Nathalie - Juin 2006
+    !! Beta for fraction of wetted foliage that will transpire
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta23          
+    ! Fin ajout Nathalie 
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbeta3           !! Beta for Transpiration 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: rveget           !! Surface resistance of vegetation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: cimean           !! STOMATE
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbetaco2         !! STOMATE
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std)                                    :: speed
+    REAL(r_std), DIMENSION(kjpindex)               :: zdefconc, zqsvegrap
+    REAL(r_std), DIMENSION(kjpindex)               :: qsatt
+
+    !
+    ! 1.  Moisture concentration at the leaf level.
+    !
+    CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+    zdefconc(:) = rau(:) * MAX( qsatt(:) - qair(:), zero )
+
+    !
+    ! 2. beta coefficient for vegetation transpiration
+    !
+
+    DO jv = 1,nvm
+
+      rveget(:,jv) = undef_sechiba
+      vbeta3(:,jv) = zero
+
+      zqsvegrap(:) = zero
+
+      DO ji = 1, kjpindex
+
+         speed = MAX(min_wind, wind(ji))
+
+         IF (qsintmax(ji,jv) .GT. min_sechiba) THEN
+            zqsvegrap(ji) = MAX(zero, qsintveg(ji,jv) / qsintmax(ji,jv))
+         ENDIF
+         
+         IF ( ( veget(ji,jv)*lai(ji,jv) .GT. min_sechiba  ) .AND. &
+              ( kzero(jv) .GT. min_sechiba ) .AND. &
+              ( swnet(ji) .GT. min_sechiba ) ) THEN
+            
+            rveget(ji,jv) = (( swnet(ji) + rayt_cste ) / swnet(ji) ) &
+                 * ((defc_plus + (defc_mult * zdefconc(ji) )) / kzero(jv)) * (un / lai(ji,jv))
+            ! Corrections Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
+            ! Introduction d'un potentiometre (rveg_pft) pour regler la somme rveg+rstruct
+            !vbeta3(ji,jv) = veget(ji,jv) * (un - zqsvegrap(ji)) * humrel(ji,jv) * &
+            !     (un / (un + speed * q_cdrag(ji) * (rveget(ji,jv) + rstruct(ji,jv))))
+            vbeta3(ji,jv) = veget(ji,jv) * (un - zqsvegrap(ji)) * humrel(ji,jv) * &
+                 (un / (un + speed * q_cdrag(ji) * (rveg_pft(jv)*(rveget(ji,jv) + rstruct(ji,jv)))))
+            ! Fin ajout Nathalie
+            ! Ajout Nathalie - Juin 2006
+            vbeta3(ji,jv) = vbeta3(ji,jv) + MIN( vbeta23(ji,jv), &
+                 veget(ji,jv) * zqsvegrap(ji) * humrel(ji,jv) * &
+                 (un / (un + speed * q_cdrag(ji) * (rveg_pft(jv)*(rveget(ji,jv) + rstruct(ji,jv))))))
+            ! Fin ajout Nathalie
+
+         ENDIF
+
+      ENDDO
+
+    ENDDO
+
+    ! STOMATE
+    cimean(:,:) = zero
+    vbetaco2(:,:) = zero
+
+    IF (long_print) WRITE (numout,*) ' diffuco_trans done '
+
+  END SUBROUTINE diffuco_trans
+
+  !! This routine computes partial beta coefficient : transpiration for each type of vegetation
+  !! STOMATE: this routine now calculates also the assimilation using the Farqhuar & al (1980) formulation
+  !!
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+  ! Nathalie - Juin 2006 - introduction de vbeta23
+  !SUBROUTINE diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, rau, u, v, q_cdrag, humrel, &
+  !                              assim_param, ccanopy, &
+  !                              veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2)
+  SUBROUTINE diffuco_trans_co2 (kjpindex, dtradia, swdown, temp_air, pb, qair, q2m, t2m, rau, u, v, q_cdrag, humrel, &
+                                assim_param, ccanopy, &
+                                veget, veget_max, lai, qsintveg, qsintmax, vbeta3, rveget, rstruct, cimean, vbetaco2, vbeta23)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia          !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swdown           !! Downwelling short wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_air         !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb               !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair             !! Lowest level specific humidity
+! Ajout Nathalie - Juin 2006 - declaration q2m
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q2m              !! 2m specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: t2m              !! 2m air temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau              !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag          !! Surface drag
+    !! min+max+opt temps, vcmax, vjmax for photosynthesis
+    REAL(r_std),DIMENSION (kjpindex,nvm,npco2), INTENT (in)  :: assim_param      
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: ccanopy          !! STOMATE: CO2 concentration inside the canopy
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: humrel           !! Soil moisture stress
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget            !! Type of vegetation fraction
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget_max        !! Max. vegetation fraction (LAI -> infty)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: lai              !! Leaf area index
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintveg         !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintmax         !! Maximum water on vegetation
+    ! AJout Nathalie - Juin 2006
+    !! Beta for fraction of wetted foliage that will transpire
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta23          
+    ! Fin ajout Nathalie
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbeta3           !! Beta for Transpiration 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: rveget           !! Surface resistance of vegetation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: rstruct          !! STOMATE
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: cimean           !! STOMATE
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vbetaco2         !! STOMATE
+
+    ! local declaration
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: vcmax
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: vjmax
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: tmin
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: topt
+    REAL(r_std),DIMENSION (kjpindex,nvm)  :: tmax
+    INTEGER(i_std)                       :: ji, jv, jl
+    REAL(r_std), DIMENSION(kjpindex)      :: leaf_ci_lowest 
+    INTEGER(i_std), DIMENSION(kjpindex)  :: ilai
+    REAL(r_std), DIMENSION(kjpindex)      :: zqsvegrap
+    REAL(r_std)                           :: speed
+    ! STOMATE:
+    LOGICAL, DIMENSION(kjpindex)         :: assimilate, calculate
+    INTEGER(i_std)                       :: nic,inic,icinic
+    INTEGER(i_std), DIMENSION(kjpindex)  :: index_calc
+    INTEGER(i_std)                       :: nia,inia,nina,inina,iainia
+    INTEGER(i_std), DIMENSION(kjpindex)  :: index_assi,index_non_assi
+    REAL(r_std), PARAMETER                :: laimax = 12.
+    REAL(r_std), PARAMETER                :: xc4_1 = .83
+    REAL(r_std), PARAMETER                :: xc4_2 = .93
+    REAL(r_std), DIMENSION(kjpindex)      :: vc2, vj2
+    REAL(r_std), DIMENSION(kjpindex)      :: assimi
+    REAL(r_std)                           :: x_1,x_2,x_3,x_4,x_5,x_6
+    REAL(r_std), DIMENSION(kjpindex)      :: gstop, gs
+    REAL(r_std), DIMENSION(kjpindex)      :: Kc, Ko, CP
+    REAL(r_std), DIMENSION(kjpindex)      :: vc, vj
+    REAL(r_std), DIMENSION(kjpindex)      :: kt, rt
+    REAL(r_std), DIMENSION(kjpindex)      :: air_relhum
+    REAL(r_std), DIMENSION(kjpindex)      :: water_lim, temp_lim
+    REAL(r_std), DIMENSION(kjpindex)      :: gstot
+    REAL(r_std), DIMENSION(kjpindex)      :: assimtot
+    REAL(r_std), DIMENSION(kjpindex)      :: leaf_gs_top   !! stomatal conductance at topmost level
+    REAL(r_std), DIMENSION(nlai+1)        :: laitab        !! tabulated LAI steps
+    REAL(r_std), DIMENSION(kjpindex)      :: qsatt
+    REAL(r_std), DIMENSION(nvm,nlai)      :: light         !! fraction of light that gets through
+    REAL(r_std), DIMENSION(kjpindex)      :: ci_gs
+    REAL(r_std)                           :: cresist       !! coefficient for resistances
+    !
+    ! calculate LAI steps
+    !
+    DO jl = 1, nlai+1
+      laitab(jl) = laimax*(EXP(.15*REAL(jl-1,r_std))-1.)/(EXP(.15*REAL(nlai,r_std))-un)
+    ENDDO
+    !
+    ! calculate light fraction that comes through at a given LAI for each vegetation type
+    !
+    DO jl = 1, nlai
+      !
+      DO jv = 1, nvm
+        !
+        light(jv,jl) = exp( -ext_coef(jv)*laitab(jl) )
+        !
+      ENDDO
+      !
+    ENDDO 
+    !
+    ! 1. Photosynthesis parameters
+    !
+    !
+    ! temperatures in K
+    !
+    tmin(:,:) = assim_param(:,:,itmin)
+    tmax(:,:) = assim_param(:,:,itmax)
+    topt(:,:) = assim_param(:,:,itopt)
+    !
+    vcmax(:,:) = assim_param(:,:,ivcmax)
+    vjmax(:,:) = assim_param(:,:,ivjmax)
+    !
+    ! estimation of relative humidity of the air
+    !
+! correction Nathalie, on utilise q2m/t2m au lieu de qair - Juin 2006
+!    CALL qsatcalc (kjpindex, temp_air, pb, qsatt)
+!    air_relhum(:) = &
+!      ( qair(:) * pb(:) / (0.622+qair(:)*0.378) ) / &
+!      ( qsatt(:)*pb(:) / (0.622+qsatt(:)*0.378 ) )
+    CALL qsatcalc (kjpindex, t2m, pb, qsatt)
+    air_relhum(:) = &
+      ( q2m(:) * pb(:) / (0.622+q2m(:)*0.378) ) / &
+      ( qsatt(:)*pb(:) / (0.622+qsatt(:)*0.378 ) )
+    !
+    DO jv = 1,nvm
+      !
+      ! 2. beta coefficient for vegetation transpiration
+      !
+      rstruct(:,jv) = rstruct_const(jv)
+      rveget(:,jv) = undef_sechiba
+      !
+      vbeta3(:,jv) = zero
+      vbetaco2(:,jv) = zero
+      !
+      cimean(:,jv) = ccanopy(:)
+      !
+      ! mask that contains points where there is photosynthesis
+      !
+      nia=0
+      nina=0
+      !
+      DO ji=1,kjpindex
+        !
+      	IF ( ( lai(ji,jv) .GT. 0.01 ) .AND. &
+              ( veget_max(ji,jv) .GT. 1.E-8 ) ) THEN
+          IF ( ( veget(ji,jv) .GT. 1.E-8 ) .AND. &
+               ( swdown(ji) .GT. min_sechiba ) .AND. &
+               ( temp_air(ji) .GT. tmin(ji,jv) ) .AND. &
+               ( temp_air(ji) .LT. tmax(ji,jv) ) .AND. &
+               ( humrel(ji,jv) .GT. min_sechiba )       ) THEN
+             !
+             assimilate(ji) = .TRUE.
+             nia=nia+1
+             index_assi(nia)=ji
+             !
+          ELSE
+             !
+             assimilate(ji) = .FALSE.
+             nina=nina+1
+             index_non_assi(nina)=ji
+             !
+          ENDIF
+        ELSE
+          !
+          assimilate(ji) = .FALSE.
+          nina=nina+1
+          index_non_assi(nina)=ji
+          !
+        ENDIF
+        !
+      ENDDO
+      !
+      gstot(:) = zero
+      assimtot(:) = zero
+      !
+      zqsvegrap(:) = zero
+      WHERE (qsintmax(:,jv) .GT. min_sechiba)
+          zqsvegrap(:) = MAX(zero, qsintveg(:,jv) / qsintmax(:,jv))
+      ENDWHERE
+      !
+      WHERE ( assimilate(:) )
+        water_lim(:) = MIN( 2.*humrel(:,jv), un )
+      ENDWHERE
+      ! give a default value of ci for all pixel that do not assimilate
+      DO jl=1,nlai
+         DO inina=1,nina
+            leaf_ci(index_non_assi(inina),jv,jl) = ccanopy(index_non_assi(inina)) * .667_r_std
+         ENDDO
+      ENDDO
+      !
+      ilai(:) = 1
+      !
+      ! Here is calculated photosynthesis (Farqhuar et al. 80)
+      ! and stomatal conductance (Ball & al. 86)
+      !
+      ! Calculating temperature dependent parameters
+      !
+      IF ( is_c4(jv) )  THEN
+        !
+        ! Case of C4 plants
+        !
+        IF (nia .GT. 0) then
+!OCL NOVREC
+          DO inia=1,nia
+            !
+            x_1 = 0.177 * EXP( 0.069*(temp_air(index_assi(inia))-tp_00) )  
+            ! = 2.0**(((temp_air(index_assi(inia))-tp_00)-25.0)/10.0)
+            !
+            kt(index_assi(inia)) = 0.7 * x_1 * 1.e6
+            rt(index_assi(inia)) = 0.8 * x_1 / &
+              ( un + EXP(1.3*(temp_air(index_assi(inia))-tmax(index_assi(inia),jv))) )
+            !
+            vc(index_assi(inia)) = vcmax(index_assi(inia),jv) & 
+                * 0.39 * x_1 * water_lim(index_assi(inia)) / &
+!                 * 0.39 * x_1  / &
+                ( (1.0+EXP(0.3*(tmin(index_assi(inia),jv)-temp_air(index_assi(inia))))) &
+                * (1.0+EXP(0.3*(temp_air(index_assi(inia))-topt(index_assi(inia),jv)))) )
+             !
+          ENDDO
+        ENDIF
+        !
+        IF (nina .GT. 0) then
+          !
+!OCL NOVREC
+          DO inina=1,nina
+            !
+            kt(index_non_assi(inina)) = zero
+            rt(index_non_assi(inina)) = zero
+            vc(index_non_assi(inina)) = zero
+            !
+          ENDDO
+          !
+        ENDIF
+        !
+      ELSE
+        !
+        ! Case of C3 plants
+        !
+        IF (nia .GT. 0) then
+          !
+!OCL NOVREC
+          DO inia=1,nia
+            !
+            temp_lim(index_assi(inia)) = &
+              (temp_air(index_assi(inia))-tmin(index_assi(inia),jv)) * &
+              (temp_air(index_assi(inia))-tmax(index_assi(inia),jv))
+            temp_lim(index_assi(inia)) = temp_lim(index_assi(inia)) / &
+              (temp_lim(index_assi(inia))-(temp_air(index_assi(inia))-&
+               topt(index_assi(inia),jv))**2)
+            !
+            Kc(index_assi(inia)) = 39.09 * EXP(.085*(temp_air(index_assi(inia))-tp_00))
+            !
+            Ko(index_assi(inia)) = 2.412 * 210000. &
+                * EXP(.085*(temp_air(index_assi(inia))-tmin(index_assi(inia),jv))) / &
+                  (temp_air(index_assi(inia))-tmin(index_assi(inia),jv))
+            !
+            CP(index_assi(inia)) = 42. * EXP( 9.46*(temp_air(index_assi(inia))-tp_00-25.)/&
+                                                           temp_air(index_assi(inia)) )
+            !
+            vc(index_assi(inia)) = vcmax(index_assi(inia),jv) * &
+               temp_lim(index_assi(inia)) * water_lim(index_assi(inia))
+!               temp_lim(index_assi(inia)) 
+            vj(index_assi(inia)) = vjmax(index_assi(inia),jv) * &
+               temp_lim(index_assi(inia)) * water_lim(index_assi(inia))
+!                temp_lim(index_assi(inia))
+            !
+          ENDDO
+          !
+        ENDIF
+        !
+        IF (nina .GT. 0) then
+          !
+!OCL NOVREC
+          DO inina=1,nina
+            ! 
+            temp_lim(index_non_assi(inina)) = zero
+            Kc(index_non_assi(inina)) = zero
+            Ko(index_non_assi(inina)) = zero
+            CP(index_non_assi(inina)) = zero
+            !
+            vc(index_non_assi(inina)) = zero
+            vj(index_non_assi(inina)) = zero
+            !
+          ENDDO
+          !
+        ENDIF
+        !
+      ENDIF      ! C3/C4
+      !
+      ! estimate assimilation and conductance for each LAI level
+      !
+      DO jl = 1, nlai
+        !
+        nic=0
+        !
+        calculate(:) = .FALSE.
+        !
+        IF (nia .GT. 0) then
+          !
+!OCL NOVREC
+          DO inia=1,nia
+            !
+            calculate(index_assi(inia)) = (laitab(jl) .LE. lai(index_assi(inia),jv) )
+            !
+            IF ( calculate(index_assi(inia)) ) THEN
+              !
+              nic=nic+1
+              index_calc(nic)=index_assi(inia)
+              !
+            ENDIF
+            !
+          ENDDO
+          !
+        ENDIF
+        !
+        ! Vmax is scaled into the canopy due to reduction of nitrogen
+        !
+        x_1 = ( un - .7_r_std * ( un - light(jv,jl) ) )
+        !
+        IF ( nic .GT. 0 ) THEN
+          !
+          DO inic=1,nic
+            !
+            vc2(index_calc(inic)) = vc(index_calc(inic)) * x_1
+            vj2(index_calc(inic)) = vj(index_calc(inic)) * x_1
+            !
+          ENDDO
+          !
+        ENDIF
+        !
+        IF ( is_c4(jv) )  THEN
+          !
+          ! assimilation for C4 plants (Collatz & al. 91)
+          !
+          DO ji = 1, kjpindex
+            !
+            assimi(ji) = zero
+            !
+          ENDDO
+          !
+          IF (nic .GT. 0) THEN
+            !
+!OCL NOVREC
+            DO inic=1,nic
+              !
+              x_1 = - ( vc2(index_calc(inic)) + 0.092 * 2.3* swdown(index_calc(inic)) * &
+                    ext_coef(jv) * light(jv,jl) )
+              x_2 = vc2(index_calc(inic)) * 0.092 * 2.3 * swdown(index_calc(inic)) * &
+                    ext_coef(jv) * light(jv,jl) 
+              x_3 = ( -x_1 - sqrt( x_1*x_1 - 4.0 * xc4_1 * x_2 ) ) / (2.0*xc4_1)
+              x_4 = - ( x_3 + kt(index_calc(inic)) * leaf_ci(index_calc(inic),jv,jl) * &
+                    1.0e-6 )
+              x_5 = x_3 * kt(index_calc(inic)) * leaf_ci(index_calc(inic),jv,jl) * 1.0e-6
+              assimi(index_calc(inic)) = ( -x_4 - sqrt( x_4*x_4 - 4. * xc4_2 * x_5 ) ) / (2.*xc4_2)
+              assimi(index_calc(inic)) = assimi(index_calc(inic)) - &
+                                                      rt(index_calc(inic))
+              !
+            ENDDO
+            !
+          ENDIF
+          !
+        ELSE
+          !
+          ! assimilation for C3 plants (Farqhuar & al. 80)
+          !
+          DO ji = 1, kjpindex
+            !
+            assimi(ji) = zero
+            !
+          ENDDO
+          !
+          IF (nic .GT. 0) THEN
+            !
+!OCL NOVREC
+            DO inic=1,nic
+              !
+              x_1 = vc2(index_calc(inic)) * leaf_ci(index_calc(inic),jv,jl) / &
+                    ( leaf_ci(index_calc(inic),jv,jl) + Kc(index_calc(inic)) * &
+                    ( un + 210000._r_std / Ko(index_calc(inic)) ) )
+              x_2 = .8855_r_std*swdown(index_calc(inic))*ext_coef(jv)*light(jv,jl)
+              x_3 = x_2+vj2(index_calc(inic))
+              x_4 = ( x_3 - sqrt( x_3*x_3 - (4._r_std*.7_r_std*x_2*vj2(index_calc(inic))) ) ) / &
+                    (2._r_std*.7_r_std)
+              x_5 = x_4 * leaf_ci(index_calc(inic),jv,jl) / &
+                    ( 4.5_r_std *  leaf_ci(index_calc(inic),jv,jl) + &
+                    10.5_r_std*CP(index_calc(inic)) ) 
+              x_6 = MIN( x_1, x_5 )
+              assimi(index_calc(inic)) = x_6 * ( un - CP(index_calc(inic))/&
+                 leaf_ci(index_calc(inic),jv,jl) ) - .011_r_std * vc2(index_calc(inic))
+              !
+            ENDDO
+            !
+          ENDIF
+          !
+        ENDIF
+        !
+        IF (nic .GT. 0) THEN
+          !
+!OCL NOVREC
+!cdir NODEP
+          DO inic=1,nic
+            !
+            ! estimate conductance (Ball & al. 86)
+            !
+            icinic=index_calc(inic)
+!            gs(icinic) = water_lim(icinic) * &
+            gs(icinic) = &
+                 ( gsslope(jv) * assimi(icinic) * &
+                 air_relhum(icinic) / ccanopy(icinic) ) &
+                  + gsoffset(jv)
+            gs(icinic) = MAX( gs(icinic), gsoffset(jv) )
+          ENDDO
+          !
+          DO inic=1,nic
+            icinic=index_calc(inic)
+            !
+            ! the new ci is calculated with
+            ! dci/dt=(ccanopy-ci)*gs/1.6-A
+            ! ci=ci+((ccanopy(icinic)-ci)*gs/1.6-&
+            !    assimi(icinic))*dtradia
+            ! we verify that ci is not out of possible values
+            !
+            ci_gs(icinic) = MIN( ccanopy(icinic), MAX( CP(icinic), &
+                   ( ccanopy(icinic) - 1.6_r_std * assimi(icinic) / &
+                     gs(icinic) ) ) ) - leaf_ci(icinic,jv,jl)
+          ENDDO
+!cdir NODEP
+          DO inic=1,nic
+            icinic=index_calc(inic)
+            !to avoid some problem of numerical stability, the leaf_ci is bufferized
+            leaf_ci(icinic,jv,jl) = leaf_ci(icinic,jv,jl) + ci_gs(icinic)/6.
+          ENDDO
+          !
+          DO inic=1,nic
+            icinic=index_calc(inic)
+            !
+            ! this might be the last level for which Ci is calculated. Store it for 
+            ! initialization of the remaining levels of the Ci array.
+            !
+            leaf_ci_lowest(icinic) = leaf_ci(icinic,jv,jl)
+          ENDDO
+          !
+!cdir NODEP
+          DO inic=1,nic
+            icinic=index_calc(inic)
+            !
+            ! total assimilation and conductance
+            assimtot(icinic) = assimtot(icinic) + &
+              assimi(icinic) * (laitab(jl+1)-laitab(jl))
+            gstot(icinic) = gstot(icinic) + &
+              gs(icinic) * (laitab(jl+1)-laitab(jl))
+            !
+            ilai(icinic) = jl
+            !
+          ENDDO
+          !
+        ENDIF
+        !
+        ! keep stomatal conductance of topmost level
+        !
+        IF ( jl .EQ. 1 ) THEN
+          !
+          leaf_gs_top(:) = zero
+          !
+          IF ( nic .GT. 0 ) then
+            !
+!OCL NOVREC
+            DO inic=1,nic
+              !
+              leaf_gs_top(index_calc(inic)) = gs(index_calc(inic))
+              !
+            ENDDO
+            !
+          ENDIF
+          !
+        ENDIF
+        !
+        IF (nia .GT. 0) THEN
+          !
+!OCL NOVREC
+          DO inia=1,nia
+            !
+            IF ( .NOT. calculate(index_assi(inia)) ) THEN
+              !
+              !   a) for plants that are doing photosynthesis, but whose LAI is lower
+              !      than the present LAI step, initialize it to the Ci of the lowest
+              !      canopy level
+              !
+              leaf_ci(index_assi(inia),jv,jl) = leaf_ci_lowest(index_assi(inia))
+              !
+            ENDIF
+            !
+          ENDDO
+          !
+        ENDIF
+        !
+      ENDDO  ! loop over LAI steps
+      !
+      ! final calculations: resistances
+      !
+      IF (nia .GT. 0) THEN
+        !
+!OCL NOVREC
+!cdir NODEP
+        DO inia=1,nia
+          !
+          iainia=index_assi(inia)
+          !
+          ! conversion from mmol/m2/s to m/s
+          !
+          gstot(iainia) = .0244*(temp_air(iainia)/tp_00)*&
+             (1013./pb(iainia))*gstot(iainia)
+          gstop(iainia) = .0244 * (temp_air(iainia)/tp_00)*&
+             (1013./pb(iainia))*leaf_gs_top(iainia)*&
+              laitab(ilai(iainia)+1)
+          !
+          rveget(iainia,jv) = un/gstop(iainia)
+          !
+        ENDDO
+        !
+        DO inia=1,nia
+          !
+          iainia=index_assi(inia)
+          !
+          ! rstruct is the difference between rtot (=1./gstot) and rveget
+          !
+          ! Correction Nathalie - le 27 Mars 2006 - Interdire a rstruct d'etre negatif
+          !rstruct(iainia,jv) = un/gstot(iainia) - &
+          !     rveget(iainia,jv)
+          rstruct(iainia,jv) = MAX( un/gstot(iainia) - &
+               rveget(iainia,jv), min_sechiba)
+          !
+        ENDDO
+        !
+        DO inia=1,nia
+          !
+          iainia=index_assi(inia)
+          !
+          speed = MAX(min_wind, wind(index_assi(inia)))
+          !
+          ! beta for transpiration
+          !
+          ! Corrections Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
+          ! Introduction d'un potentiometre (rveg_pft) pour regler la somme rveg+rstruct
+          !vbeta3(iainia,jv) = veget_max(iainia,jv) * &
+          !  (un - zqsvegrap(iainia)) * &
+          !  (un / (un + speed * q_cdrag(iainia) * (rveget(iainia,jv) + &
+          !   rstruct(iainia,jv))))
+          cresist=(un / (un + speed * q_cdrag(iainia) * &
+               (rveg_pft(jv)*(rveget(iainia,jv) + rstruct(iainia,jv)))))
+
+          vbeta3(iainia,jv) = veget_max(iainia,jv) * &
+            (un - zqsvegrap(iainia)) * cresist + &
+!!$          ! Ajout Nathalie - Juin 2006
+!!$          vbeta3(iainia,jv) = vbeta3(iainia,jv) + &
+          ! Corrections Nathalie - le 09 novembre 2009 : veget => veget_max
+!               MIN( vbeta23(iainia,jv), veget(iainia,jv) * &
+               MIN( vbeta23(iainia,jv), veget_max(iainia,jv) * &
+!               zqsvegrap(iainia) * humrel(iainia,jv) * &
+               zqsvegrap(iainia) * cresist )
+          ! Fin ajout Nathalie
+          !
+          ! beta for assimilation. The difference is that surface 
+          ! covered by rain (un - zqsvegrap(iainia)) is not taken into account
+          ! 1.6 is conversion for H2O to CO2 conductance
+          ! vbetaco2(iainia,jv) = veget_max(iainia,jv) * &
+          !   (un / (un + q_cdrag(iainia) * &
+          !   (rveget(iainia,jv))))/1.6
+          !
+          vbetaco2(iainia,jv) = veget_max(iainia,jv) * &
+             (un / (un + speed * q_cdrag(iainia) * &
+             (rveget(iainia,jv) + rstruct(iainia,jv)))) / 1.6
+          !
+          ! cimean is the "mean ci" calculated in such a way that assimilation 
+          ! calculated in enerbil is equivalent to assimtot
+          !
+          cimean(iainia,jv) = ccanopy(iainia) - &
+             assimtot(iainia) / &
+             ( vbetaco2(iainia,jv)/veget_max(iainia,jv) * &
+             rau(iainia) * speed * q_cdrag(iainia))
+          !
+        ENDDO
+        !
+      ENDIF
+      !
+    END DO         ! loop over vegetation types
+    !
+    IF (long_print) WRITE (numout,*) ' diffuco_trans_co2 done '
+
+  END SUBROUTINE diffuco_trans_co2
+
+  !! This routine combines previous partial beta coeeficient and calculates
+  !! alpha and complete beta coefficient
+  !!
+  ! Ajout qsintmax dans les arguments de la routine Nathalie / le 13-03-2006
+  SUBROUTINE diffuco_comb (kjpindex, dtradia, humrel, rau, u, v, q_cdrag, pb, qair, temp_sol, temp_air, &
+       & snow, veget, lai, vbeta1, vbeta2, vbeta3 , vbeta4, valpha, vbeta, qsintmax)    
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia          !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau              !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag          !! Surface drag
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb               !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair             !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol         !! Skin temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_air         !! lower air temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: snow             !! Snow mass
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget            !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: lai              !! Leaf area index
+    ! Ajout Nathalie / le 13-03-2006
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: qsintmax   !! Maximum water on vegetation
+    ! modified fields 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: vbeta1           !! Beta for sublimation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: vbeta4           !! Beta for Bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)         :: humrel           !! Soil moisture stress
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)     :: vbeta2           !! Beta for Interception for
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)     :: vbeta3           !! Beta for Transpiration 
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: valpha           !! TotalAlpha coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vbeta            !! Total beta coefficient
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std)                                    :: zevtest, zsoil_moist, zrapp
+    REAL(r_std), DIMENSION(kjpindex)               :: vbeta2sum, vbeta3sum
+    REAL(r_std), DIMENSION(kjpindex)               :: vegetsum, vegetsum2
+    REAL(r_std), DIMENSION(kjpindex)               :: qsatt
+    LOGICAL, DIMENSION(kjpindex)                  :: toveg, tosnow
+    REAL(r_std)                                    :: coeff_dew_veg
+
+    vbeta2sum(:) = zero
+    vbeta3sum(:) = zero
+    DO jv = 1, nvm
+      vbeta2sum(:) = vbeta2sum(:) + vbeta2(:,jv)
+      vbeta3sum(:) = vbeta3sum(:) + vbeta3(:,jv)
+    ENDDO 
+
+    !
+    ! 1. The beta and alpha coefficients are calculated.
+    !
+
+    vbeta(:) = un
+    valpha(:) = un
+
+    !
+    ! 2. if snow is lower than critical value
+    !
+
+    DO ji = 1, kjpindex
+
+      IF  (snow(ji) .LT. snowcri) THEN
+
+          vbeta(ji) = vbeta4(ji) + vbeta2sum(ji) + vbeta3sum(ji)
+
+          IF (vbeta(ji) .LT. min_sechiba) THEN
+             vbeta(ji) = zero
+          END IF
+
+      END IF
+
+    ENDDO
+
+    !
+    ! 3. If we are in presence of dew.
+    !
+
+    ! for vectorization: some arrays
+    vegetsum(:) = zero
+    DO jv = 1, nvm
+      vegetsum(:) = vegetsum(:) + veget(:,jv)
+    ENDDO
+    vegetsum2(:) = zero
+    DO jv = 2, nvm
+      vegetsum2(:) = vegetsum2(:) + veget(:,jv)
+    ENDDO
+
+    CALL qsatcalc (kjpindex, temp_sol, pb, qsatt)
+
+    !
+    ! 3.1 decide where the water goes (soil, vegetation, or snow)
+    !     when air moisture exceeds saturation.
+    ! 
+    toveg(:) = .FALSE.
+    tosnow(:) = .FALSE.
+    DO ji = 1, kjpindex
+      IF ( qsatt(ji) .LT. qair(ji) ) THEN
+          IF (temp_air(ji) .GT. tp_00) THEN
+              !
+              ! 3.1.1  If it is not freezing dew is put into the 
+              !        interception reservoir and on the bare soil.
+              toveg(ji) = .TRUE.
+          ELSE
+              !
+              ! 3.1.2  If it is freezing water is put into the 
+              !        snow reservoir.
+              tosnow(ji) = .TRUE.
+          ENDIF
+      ENDIF
+    END DO
+
+    ! 3.1.3 now modify valpha and vbetas where necessary.
+    !
+    ! 3.1.3.1 Soil and snow (2d)
+    !
+    DO ji = 1, kjpindex
+      IF ( toveg(ji) ) THEN
+        vbeta1(ji) = zero
+        vbeta4(ji) = veget(ji,1)
+        ! Correction Nathalie - le 13-03-2006: le vbeta ne sera calcule qu'une fois tous les vbeta2 redefinis
+        !vbeta(ji) = vegetsum(ji)
+        vbeta(ji) = vbeta4(ji)
+        valpha(ji) = un
+      ENDIF
+      IF ( tosnow(ji) ) THEN
+        vbeta1(ji) = un
+        vbeta4(ji) = zero
+        vbeta(ji) = un
+        valpha(ji) = un
+      ENDIF
+    ENDDO
+    !
+    ! 3.1.3.2 vegetation (3d)
+    !
+    DO jv = 1, nvm
+      !
+      DO ji = 1, kjpindex
+        !
+         ! Correction Nathalie - 13-03-2006 / si qsintmax=0, vbeta2=0
+        IF ( toveg(ji) ) THEN
+           IF (qsintmax(ji,jv) .GT. min_sechiba) THEN
+              !MM
+              ! Compute part of dew that can be intercepted by leafs.
+              IF ( lai(ji,jv) .GT. min_sechiba) THEN
+                IF (lai(ji,jv) .GT. 1.5) THEN
+                    coeff_dew_veg= &
+                         &   0.000017*lai(ji,jv)**5 &
+                         & - 0.000824*lai(ji,jv)**4 &
+                         & + 0.014843*lai(ji,jv)**3 &
+                         & - 0.110112*lai(ji,jv)**2 &
+                         & + 0.205673*lai(ji,jv) &
+                         & + 0.887773
+                 ELSE
+                    coeff_dew_veg=un
+                 ENDIF
+              ELSE
+                 coeff_dew_veg=zero
+              ENDIF
+              vbeta2(ji,jv) = coeff_dew_veg*veget(ji,jv)
+!              vbeta2(ji,jv) = veget(ji,jv)
+           ELSE
+              vbeta2(ji,jv) = zero
+           ENDIF
+           vbeta(ji) = vbeta(ji) + vbeta2(ji,jv)
+        ENDIF
+        IF ( tosnow(ji) ) vbeta2(ji,jv) = zero
+        !
+      ENDDO
+      !
+    ENDDO
+
+    !
+    ! 3.2  In any case there is no transpiration when air moisture is too high.
+    !
+    
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( qsatt(ji) .LT. qair(ji) ) THEN
+          vbeta3(ji,jv) = zero
+          humrel(ji,jv) = zero
+        ENDIF
+      ENDDO
+    ENDDO
+
+    !
+    ! 3.2_bis  In any case there is no interception loss on bare soil.
+    !
+
+    DO ji = 1, kjpindex
+       IF ( qsatt(ji) .LT. qair(ji) ) THEN
+          vbeta2(ji,1) = zero
+       ENDIF
+    ENDDO
+
+    IF (long_print) WRITE (numout,*) ' diffuco_comb done '
+
+  END SUBROUTINE diffuco_comb
+
+  SUBROUTINE diffuco_raerod (kjpindex, u, v, q_cdrag, raero)
+    !
+    ! Simply computes the aerodynamic resistance. For the moment it is
+    ! only used as a diagnostic but that may change !
+    !
+    IMPLICIT NONE
+    !
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag          !! Surface drag
+    ! output filed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: raero            !! Aerodynamic resistance
+    !
+    ! local declaration
+    INTEGER(i_std)                                :: ji
+    REAL(r_std)                                    :: speed
+    !
+    DO ji=1,kjpindex
+       !
+       speed = MAX(min_wind, wind(ji))
+       raero(ji) = un / (q_cdrag(ji)*speed)
+       !
+    ENDDO
+    !
+  END SUBROUTINE diffuco_raerod
+
+END MODULE diffuco
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/enerbil.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/enerbil.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/enerbil.f90	(revision 55)
@@ -0,0 +1,1048 @@
+!!
+!! This module computes energy bilan on continental surface
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!! 
+MODULE enerbil
+
+  ! routines called : restput, restget
+  !
+  USE ioipsl
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_veg
+  USE sechiba_io
+  USE parallel
+!  USE write_field_p, only : WriteFieldI_p  
+  IMPLICIT NONE
+
+  ! public routines :
+  ! enerbil_main
+  ! enerbil_fusion
+  PRIVATE
+  PUBLIC :: enerbil_main, enerbil_fusion,enerbil_clear
+
+  !
+  ! variables used inside enerbil module : declaration and initialisation
+  !
+  LOGICAL, SAVE                              :: l_first_enerbil=.TRUE.  !! Initialisation has to be done one time
+
+  CHARACTER(LEN=80), SAVE                    :: var_name                !! To store variables names for I/O
+
+  ! one dimension array allocated, computed and used in enerbil module exclusively
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: psold                   !! Old surface dry static energy
+  !! saturated specific humudity for old temperature 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: qsol_sat
+  !! derivative of satured specific humidity at the old temperature
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: pdqsold
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: psnew                   !! New surface static energy
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: qsol_sat_new            !! New saturated surface air moisture
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: netrad                  !! Net radiation 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: lwabs                   !! LW radiation absorbed by the surface
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: lwup                    !! Long-wave up radiation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: lwnet                   !! Net Long-wave radiation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: fluxsubli               !! Energy of sublimation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: qsat_air                !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: tair                    !!
+CONTAINS
+
+  !! 
+  !! Main routine for *enerbil* module
+  !! - called only one time for initialisation
+  !! - called every time step
+  !! - called one more time at last time step for writing _restart_ file
+  !!
+  !! Algorithm:
+  !! - call enerbil_begin for initialisation
+  !! - call enerbil_surftemp for psnew and qsol_sat_new
+  !! - call enerbil_flux for tsol_new, netrad, vevapp, fluxlat and fluxsens
+  !! - call enerbil_evapveg for evaporation and transpiration
+  !!
+  !! @call enerbil_begin
+  !! @call enerbil_surftemp
+  !! @call enerbil_flux
+  !! @call enerbil_evapveg
+  !!
+  SUBROUTINE enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+     & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef, &
+     & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, &
+     & cimean, ccanopy, emis, soilflx, soilcap, q_cdrag, humrel, fluxsens, fluxlat, &
+     & vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, t2mdiag, temp_sol, tsol_rad, &
+     & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id ) 
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                         :: kjit             !! Time step number 
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size
+    INTEGER(i_std),INTENT (in)                         :: rest_id,hist_id  !! _Restart_ file and _history_ file identifier
+    INTEGER(i_std),INTENT (in)                         :: hist2_id         !! _history_ file 2 identifier
+    REAL(r_std), INTENT (in)                           :: dtradia          !! Time step in seconds
+    LOGICAL, INTENT(in)                               :: ldrestart_read   !! Logical for _restart_ file to read
+    LOGICAL, INTENT(in)                               :: ldrestart_write  !! Logical for _restart_ file to write
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: index            !! Indeces of the points on the map
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: zlev             !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: lwdown           !! Down-welling long-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swnet            !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: epot_air         !! Air potential energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_air         !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: u                !! zonal wind (m/s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: v                !! north-south wind (m/s)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: petAcoef         !! PetAcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: petBcoef         !! PetBcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: qair             !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: peqAcoef         !! PeqAcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: peqBcoef         !! PeqBcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: pb               !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: rau              !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: vbeta            !! Resistance coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: valpha           !! Resistance coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: vbeta1           !! Snow resistance 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: vbeta4           !! Bare soil resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: emis             !! Emissivity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: soilflx          !! Soil flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: soilcap          !! Soil calorific capacity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: q_cdrag          !! This is the cdrag without the wind multiplied
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: ccanopy          !! CO2 concentration in the canopy
+    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in) :: humrel           !! Relative humidity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vbeta2           !! Interception resistance
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vbeta3           !! Vegetation resistance
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vbetaco2         !! Vegetation resistance to CO2
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: cimean           !! mean Ci
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: evapot           !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: evapot_corr !! Soil Potential Evaporation Correction
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: temp_sol         !! Soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: qsurf            !! Surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: fluxsens         !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: fluxlat          !! Latent chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: tsol_rad         !! Tsol_rad
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: vevapp           !! Total of evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: gpp              !! Assimilation, gC/m**2 total area.
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: temp_sol_new     !! New soil temperature
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vevapnu          !! Bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: vevapsno         !! Snow evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: transpir         !! Transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vevapwet         !! Interception 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: t2mdiag          !! 2-meter temperature
+    !
+    ! LOCAL
+    !
+    REAL(r_std),DIMENSION (kjpindex) :: epot_air_new, qair_new
+    !
+    ! do initialisation 
+    !
+    IF (l_first_enerbil) THEN
+
+        IF (long_print) WRITE (numout,*) ' l_first_enerbil : call enerbil_init '
+        CALL enerbil_init (kjit, ldrestart_read, kjpindex, index, rest_id, qair, temp_sol, temp_sol_new,  &
+             &             qsurf, tsol_rad, vevapp, fluxsens, fluxlat, gpp, evapot, evapot_corr)
+
+        CALL enerbil_var_init (kjpindex, temp_air, t2mdiag)
+
+        RETURN 
+
+    ENDIF
+
+    !
+    ! prepares restart file for the next simulation
+    !
+    IF (ldrestart_write) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to complete restart file with ENERBIL variables '
+
+        var_name= 'temp_sol'  
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  temp_sol, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'qsurf'  
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  qsurf, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'evapot'  
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  evapot, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'evapot_corr'  
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  evapot_corr, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'tsolrad'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  tsol_rad, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'evapora'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  vevapp, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'fluxlat'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  fluxlat, 'scatter',  nbp_glo, index_g)
+
+        var_name= 'fluxsens'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit,  fluxsens, 'scatter',  nbp_glo, index_g)
+
+        IF ( control%stomate_watchout .OR. control%ok_co2 ) THEN
+
+          ! The gpp could in principle be recalculated at the beginning of the run.
+          ! However, we would need several variables that are not stored in the restart files.
+          !
+          var_name= 'gpp'
+          CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, gpp, 'scatter',  nbp_glo, index_g)
+
+        ENDIF
+
+        RETURN 
+
+    END IF
+
+    !
+    !
+    ! 1. computes some initialisation: psold, qsol_sat and pdqsold
+    !
+    CALL enerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, psold, qsol_sat, pdqsold, netrad, emis)
+
+    !
+    ! 2. computes psnew, qsol_sat_new, temp_sol_new, qair_new and epot_air_new
+    !
+    CALL enerbil_surftemp (kjpindex, dtradia, zlev, emis, &
+       & epot_air, petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
+       & valpha, vbeta1, soilcap, lwdown, swnet, psnew, qsol_sat_new, temp_sol_new, &
+       & qair_new, epot_air_new)
+
+    !
+    ! 3. computes lwup, lwnet, tsol_rad, netrad, qsurf, vevapp, evapot, evapot_corr, fluxlat, fluxsubli and fluxsens
+    !
+
+    CALL enerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, q_cdrag, vbeta, valpha, vbeta1, &
+       & qair_new, epot_air_new, psnew, qsurf, &
+       & fluxsens , fluxlat , fluxsubli, vevapp, temp_sol_new, lwdown, swnet, &
+       & lwup, lwnet, pb, tsol_rad, netrad, evapot, evapot_corr)
+
+    !
+    ! 4. computes in details evaporation and transpiration
+    !
+
+    CALL enerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, cimean, &
+       & ccanopy, rau, u, v, q_cdrag, qair_new, humrel, vevapsno, vevapnu , vevapwet, transpir, gpp, evapot)
+
+    !
+    ! 5. diagnose 2-meter temperatures
+    !
+
+    CALL enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
+
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite(hist_id, 'netrad', kjit, netrad, kjpindex, index)
+       CALL histwrite(hist_id, 'evapot', kjit, evapot, kjpindex, index)
+       CALL histwrite(hist_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+       CALL histwrite(hist_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+       CALL histwrite(hist_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'netrad', kjit, netrad, kjpindex, index)
+          CALL histwrite(hist2_id, 'evapot', kjit, evapot, kjpindex, index)
+          CALL histwrite(hist2_id, 'evapot_corr', kjit, evapot_corr, kjpindex, index)
+          CALL histwrite(hist2_id, 'lwdown', kjit, lwabs,  kjpindex, index)
+          CALL histwrite(hist2_id, 'lwnet',  kjit, lwnet,  kjpindex, index)
+       ENDIF
+    ELSE
+       CALL histwrite(hist_id, 'LWnet', kjit, lwnet, kjpindex, index)
+       CALL histwrite(hist_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+       CALL histwrite(hist_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'LWnet', kjit, lwnet, kjpindex, index)
+          CALL histwrite(hist2_id, 'Qv', kjit, fluxsubli, kjpindex, index)
+          CALL histwrite(hist2_id, 'PotEvap', kjit, evapot_corr, kjpindex, index)
+       ENDIF
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' enerbil_main Done '
+
+  END SUBROUTINE enerbil_main
+
+  !! Algorithm:
+  !! - dynamic allocation for local array 
+  !!
+  SUBROUTINE enerbil_init (kjit, ldrestart_read, kjpindex, index, rest_id, qair, temp_sol, temp_sol_new, &
+       &                   qsurf, tsol_rad, vevapp, fluxsens, fluxlat, gpp, evapot, evapot_corr)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                              :: kjit               !! Time step number 
+    LOGICAL ,INTENT (in)                                    :: ldrestart_read     !! Logical for _restart_ file to read
+    INTEGER(i_std), INTENT (in)                              :: kjpindex           !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)         :: index              !! Indeces of the points on the map
+    INTEGER(i_std), INTENT (in)                              :: rest_id            !! _Restart_ file identifier 
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair               !! Lowest level specific humidity
+    ! output scalar
+    ! output fields, they need to initialized somehow for the model forcing ORCHIDEE.
+    !
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: temp_sol           !! Soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_new       !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf              !! near surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad           !! Tsol_rad
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp           !! Total of evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsens         !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxlat          !! Latent chaleur flux
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: gpp                !! Assimilation, gC/m**2 total area.
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: evapot             !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: evapot_corr        !! Soil Potential Evaporation Correction
+
+    ! local declaration
+    INTEGER(i_std)                                          :: ier
+
+    ! initialisation
+    IF (l_first_enerbil) THEN 
+        l_first_enerbil=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_enerbil false . we stop '
+        STOP 'enerbil_init'
+    ENDIF
+
+    ALLOCATE (psold(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in psold allocation. We stop.We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (qsol_sat(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in qsol_sat allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (pdqsold(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in pdqsold allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (psnew(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in psnew allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (qsol_sat_new(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in qsol_sat_new allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (netrad(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in netrad allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (lwabs(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in lwabs allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (lwup(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in lwup allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (lwnet(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in lwnet allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (fluxsubli(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in fluxsubli allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (qsat_air(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in qsat_air allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ALLOCATE (tair(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in tair allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'enerbil_init'
+    END IF
+
+    ! open restart input file done by enerbil_init
+    ! and read data from restart input file for ENERBIL process
+
+    IF (ldrestart_read) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to read a restart file for HYDROLOGIC variables'
+
+        var_name='temp_sol'
+        CALL ioconf_setatt('UNITS', 'K')
+        CALL ioconf_setatt('LONG_NAME','Surface temperature')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp_sol, "gather", nbp_glo, index_g)
+        !
+        !Config Key  = ENERBIL_TSURF
+        !Config Desc = Initial temperature if not found in restart
+        !Config Def  = 280.
+        !Config Help = The initial value of surface temperature if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (temp_sol, val_exp,'ENERBIL_TSURF', 280._r_std)
+        !
+        var_name= 'qsurf'
+        CALL ioconf_setatt('UNITS', 'g/g')
+        CALL ioconf_setatt('LONG_NAME','near surface specific humidity')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., qsurf, "gather", nbp_glo, index_g)
+        IF ( ALL( qsurf(:) .EQ. val_exp ) ) THEN 
+           qsurf(:) = qair(:)
+        ENDIF
+        !
+        var_name= 'evapot'
+        CALL ioconf_setatt('UNITS', 'mm/d')
+        CALL ioconf_setatt('LONG_NAME','Soil Potential Evaporation')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evapot, "gather", nbp_glo, index_g)
+        !
+        var_name= 'evapot_corr'
+        CALL ioconf_setatt('UNITS', 'mm/d')
+        CALL ioconf_setatt('LONG_NAME','Corrected Soil Potential Evaporation')
+        IF ( ok_var(var_name) ) THEN
+           CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evapot_corr, "gather", nbp_glo, index_g)
+        ENDIF
+        !
+        !Config Key  = ENERBIL_EVAPOT
+        !Config Desc = Initial Soil Potential Evaporation
+        !Config Def  = 0.0
+        !Config Help = The initial value of soil potential evaporation if its value 
+        !Config        is not found in the restart file. This should only be used if
+        !Config        the model is started without a restart file. 
+        !
+        CALL setvar_p (evapot, val_exp, 'ENERBIL_EVAPOT', zero)
+        IF ( ok_var("evapot_corr") ) THEN
+           CALL setvar_p (evapot_corr, val_exp, 'ENERBIL_EVAPOT', zero)
+        ENDIF
+        !
+        var_name= 'tsolrad'
+        CALL ioconf_setatt('UNITS', 'K')
+        CALL ioconf_setatt('LONG_NAME','Radiative surface temperature')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., tsol_rad, "gather", nbp_glo, index_g)
+        IF ( ALL( tsol_rad(:) .EQ. val_exp ) ) THEN 
+           tsol_rad(:) = temp_sol(:)
+        ENDIF
+        !
+        ! Set the fluxes so that we have something reasonable and not NaN on some machines
+        !
+        var_name= 'evapora'
+        CALL ioconf_setatt('UNITS', 'Kg/m^2/dt')
+        CALL ioconf_setatt('LONG_NAME','Evaporation')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vevapp, "gather", nbp_glo, index_g)
+        IF ( ALL( vevapp(:) .EQ. val_exp ) ) THEN 
+           vevapp(:) = zero
+        ENDIF
+        !
+        var_name= 'fluxlat'
+        CALL ioconf_setatt('UNITS', 'W/m^2')
+        CALL ioconf_setatt('LONG_NAME','Latent heat flux')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., fluxlat, "gather", nbp_glo, index_g)
+        IF ( ALL( fluxlat(:) .EQ. val_exp ) ) THEN 
+           fluxlat(:) = zero
+        ENDIF
+        !
+        var_name= 'fluxsens'
+        CALL ioconf_setatt('UNITS', 'W/m^2')
+        CALL ioconf_setatt('LONG_NAME','Sensible heat flux')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., fluxsens, "gather", nbp_glo, index_g)
+        IF ( ALL( fluxsens(:) .EQ. val_exp ) ) THEN 
+           fluxsens(:) = zero
+        ENDIF
+        !
+        ! If we are with STOMATE
+        !
+        IF ( control%stomate_watchout .OR. control%ok_co2 ) THEN
+
+          ! The gpp could in principle be recalculated at the beginning of the run.
+          ! However, we would need several variables that are not stored in the restart files.
+          var_name= 'gpp'
+          CALL ioconf_setatt('UNITS', 'gC/m**2/time step')
+          CALL ioconf_setatt('LONG_NAME','Gross primary productivity')
+          CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., gpp, "gather", nbp_glo, index_g)
+
+          IF ( ALL( gpp(:,:) .EQ. val_exp ) ) THEN
+             gpp(:,:) = zero
+          ENDIF
+
+        ENDIF
+
+        ! initialises temp_sol_new 
+        ! saved in thermosoil
+        var_name='temp_sol_new'
+        CALL ioconf_setatt('UNITS', 'K')
+        CALL ioconf_setatt('LONG_NAME','New Surface temperature')
+        IF ( ok_var(var_name) ) THEN
+           CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp_sol_new, "gather", nbp_glo, index_g)
+           IF ( ALL( temp_sol_new(:) .EQ. val_exp ) ) THEN
+              temp_sol_new(:) = temp_sol(:)
+           ENDIF
+        ELSE
+           ! initialises temp_sol_new 
+           temp_sol_new(:) = temp_sol(:)
+        ENDIF
+
+    ELSE
+       ! initialises temp_sol_new 
+       temp_sol_new(:) = temp_sol(:)
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' enerbil_init done '
+
+  END SUBROUTINE enerbil_init
+
+  SUBROUTINE enerbil_clear ()
+    l_first_enerbil=.TRUE.
+    IF ( ALLOCATED (psold)) DEALLOCATE (psold)
+    IF ( ALLOCATED (qsol_sat)) DEALLOCATE (qsol_sat)
+    IF ( ALLOCATED (pdqsold)) DEALLOCATE (pdqsold)
+    IF ( ALLOCATED (psnew)) DEALLOCATE (psnew)
+    IF ( ALLOCATED (qsol_sat_new)) DEALLOCATE (qsol_sat_new)
+    IF ( ALLOCATED (netrad)) DEALLOCATE (netrad)
+    IF ( ALLOCATED (lwabs)) DEALLOCATE (lwabs)
+    IF ( ALLOCATED (lwup)) DEALLOCATE (lwup)
+    IF ( ALLOCATED (lwnet)) DEALLOCATE (lwnet)
+    IF ( ALLOCATED (fluxsubli)) DEALLOCATE (fluxsubli)
+    IF ( ALLOCATED (qsat_air)) DEALLOCATE (qsat_air)
+    IF ( ALLOCATED (tair)) DEALLOCATE (tair)
+   !
+   ! open restart input file done by enerbil_init
+    ! and read data from restart input file for ENERBIL process
+
+ 
+  END SUBROUTINE enerbil_clear
+  
+  SUBROUTINE enerbil_var_init (kjpindex, temp_air, t2mdiag)
+
+    ! interface description
+    ! input scalar
+    INTEGER(i_std), INTENT(in)                         :: kjpindex       !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_air       !! Air temperature in Kelvin
+    ! modified fields
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: t2mdiag        !! 2-meter temperature
+
+    CALL enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
+
+    IF (long_print) WRITE (numout,*) ' enerbil_var_init done '
+
+  END SUBROUTINE enerbil_var_init
+
+  !! This routines computes psold, qsol_sat, pdqsold and netrad
+  !!
+  SUBROUTINE enerbil_begin (kjpindex, temp_sol, lwdown, swnet, pb, psold, qsol_sat, pdqsold, netrad, emis)
+
+    ! interface description
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol         !! Soil temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: lwdown           !! Down-welling long-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: swnet            !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: pb               !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: emis             !! Emissivity
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: psold            !! Old surface dry static energy
+    !! Saturated specific humudity for old temperature 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: qsol_sat
+    !! Derivative of satured specific humidity at the old temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: pdqsold
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: netrad           !! Net radiation 
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji
+    REAL(r_std), DIMENSION(kjpindex)               :: dev_qsol
+    REAL(r_std), PARAMETER                         :: missing = 999998.
+    ! initialisation
+
+    !
+    ! 1. computes psold
+    !
+    psold(:) = temp_sol(:)*cp_air
+    !
+    ! 2. computes qsol_sat
+    !
+    CALL qsatcalc (kjpindex, temp_sol, pb, qsol_sat)
+
+    IF ( diag_qsat ) THEN
+      IF ( ANY(ABS(qsol_sat(:)) .GT. missing) ) THEN
+        DO ji = 1, kjpindex
+          IF ( ABS(qsol_sat(ji)) .GT. missing) THEN
+            WRITE(numout,*) 'ERROR on ji = ', ji
+            WRITE(numout,*) 'temp_sol(ji),  pb(ji) :', temp_sol(ji),  pb(ji)
+            CALL ipslerr (3,'enerbil_begin', &
+ &           'qsol too high ','','')
+          ENDIF
+        ENDDO
+      ENDIF
+    ENDIF
+
+    !
+    ! 3. computes pdqsold
+    !
+    CALL dev_qsatcalc (kjpindex, temp_sol, pb, dev_qsol)
+    DO ji = 1, kjpindex
+      pdqsold(ji) = dev_qsol(ji) * ( pb(ji)**kappa ) / cp_air
+    ENDDO
+
+    IF ( diag_qsat ) THEN
+      IF ( ANY(ABS( pdqsold(:)) .GT. missing) ) THEN
+        DO ji = 1, kjpindex
+          IF ( ABS( pdqsold(ji)) .GT. missing ) THEN
+            WRITE(numout,*) 'ERROR on ji = ', ji
+            WRITE(numout,*) 'temp_sol(ji),  pb(ji) :', temp_sol(ji),  pb(ji)
+            CALL ipslerr (3,'enerbil_begin', &
+ &           'pdqsold too high ','','')
+          ENDIF
+        ENDDO
+      ENDIF
+    ENDIF
+
+    !
+    ! 4. computes netrad and absorbed LW radiation absorbed at the surface 
+    !
+    lwabs(:) = emis(:) * lwdown(:)
+    netrad(:) = lwdown(:) + swnet (:) - (emis(:) * c_stefan * temp_sol(:)**4 + (un - emis(:)) * lwdown(:)) 
+    !
+    IF (long_print) WRITE (numout,*) ' enerbil_begin done '
+
+  END SUBROUTINE enerbil_begin
+
+  !! This routine computes psnew and qsol_sat_new
+  !!
+  !! Computes the energy balance at the surface with an implicit scheme 
+  !! that is connected to the Richtmyer and Morton algorithm of the PBL.
+  !!
+  SUBROUTINE enerbil_surftemp (kjpindex, dtradia, zlev, emis, epot_air, &
+     & petAcoef, petBcoef, qair, peqAcoef, peqBcoef, soilflx, rau, u, v, q_cdrag, vbeta,&
+     & valpha, vbeta1, soilcap, lwdown, swnet, psnew, qsol_sat_new, temp_sol_new, &
+     & qair_new, epot_air_new) 
+
+    ! interface 
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size
+    REAL(r_std), INTENT(in)                                  :: dtradia       !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: zlev          !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: emis          !! Emissivity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: epot_air      !! Air potential energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petAcoef      !! PetAcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petBcoef      !! PetBcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair          !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqAcoef      !! PeqAcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqBcoef      !! PeqBcoef
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: soilflx       !! Soil flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau           !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u, v          !! Wind
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag       !!
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: vbeta         !! Resistance coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: valpha        !! Resistance coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: vbeta1        !! Snow resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: soilcap       !! Soil calorific capacity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: lwdown        !! Down-welling long-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet         !! Net surface short-wave flux
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: psnew         !! New surface static energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsol_sat_new  !! New saturated surface air moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: temp_sol_new  !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qair_new      !! New air moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: epot_air_new  !! New air temperature
+
+
+    ! local declaration
+    INTEGER(i_std)                  :: ji
+    REAL(r_std),DIMENSION (kjpindex) :: zicp
+    REAL(r_std)                      :: fevap
+    REAL(r_std)                      :: sensfl_old, larsub_old, lareva_old, dtheta, sum_old, sum_sns
+    REAL(r_std)                      :: zikt, zikq, netrad_sns, sensfl_sns, larsub_sns, lareva_sns
+    REAL(r_std)                      :: speed
+
+    zicp = un / cp_air
+    !
+    DO ji=1,kjpindex
+      !
+      !
+      ! Help variables
+      !
+      !
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+      !
+      zikt = 1/(rau(ji) * speed * q_cdrag(ji))
+      zikq = 1/(rau(ji) * speed * q_cdrag(ji))
+      !
+      !
+      !  The first step is to compute the fluxes for the old surface conditions
+      !
+      !
+      sensfl_old = (petBcoef(ji) -  psold(ji)) / (zikt -  petAcoef(ji))
+      larsub_old = chalsu0 * vbeta1(ji) * (peqBcoef(ji) -  qsol_sat(ji)) / (zikq - peqAcoef(ji))
+      lareva_old = chalev0 * (un - vbeta1(ji)) * vbeta(ji) * &
+           & (peqBcoef(ji) -  valpha(ji) * qsol_sat(ji)) / (zikq - peqAcoef(ji))
+      !
+      !
+      !  Next the sensitivity terms are computed
+      !
+      !
+      netrad_sns = zicp(ji) * quatre * emis(ji) * c_stefan * ((zicp(ji) * psold(ji))**3)
+      sensfl_sns = un / (zikt -  petAcoef(ji))
+      larsub_sns = chalsu0 * vbeta1(ji) * zicp(ji) * pdqsold(ji) / (zikq - peqAcoef(ji))
+      lareva_sns = chalev0 * (un - vbeta1(ji)) * vbeta(ji) * valpha(ji) * &
+           & zicp(ji) * pdqsold(ji) / (zikq - peqAcoef(ji))
+      !
+      !
+      !  Now we are solving the energy balance
+      !
+      !
+      sum_old = netrad(ji) + sensfl_old + larsub_old + lareva_old + soilflx(ji)
+      sum_sns = netrad_sns + sensfl_sns + larsub_sns + lareva_sns
+      dtheta = dtradia * sum_old / (zicp(ji) * soilcap(ji) + dtradia * sum_sns)
+      !
+      !
+      psnew(ji) =  psold(ji) + dtheta
+      !
+      qsol_sat_new(ji) = qsol_sat(ji) + zicp(ji) * pdqsold(ji) * dtheta
+      !
+      temp_sol_new(ji) = psnew(ji) / cp_air
+      !
+      epot_air_new(ji) = zikt * (sensfl_old - sensfl_sns * dtheta) + psnew(ji)
+      !
+      fevap = (lareva_old - lareva_sns * dtheta) + (larsub_old - larsub_sns * dtheta)
+      IF ( ABS(fevap) < EPSILON(un) ) THEN
+        qair_new(ji) = qair(ji)
+      ELSE
+        qair_new(ji) = zikq * un / (chalev0 * (un - vbeta1(ji)) * vbeta(ji) * valpha(ji) + &
+           & chalsu0 *  vbeta1(ji)) * fevap + qsol_sat_new(ji)
+      ENDIF
+      !
+      !
+    ENDDO
+
+    IF (long_print) WRITE (numout,*) ' enerbil_surftemp done '
+
+  END SUBROUTINE enerbil_surftemp
+
+  !! This routine computes tsol_new, netrad, vevapp, fluxlat, fluxsubli and fluxsens
+  !!
+  SUBROUTINE enerbil_flux (kjpindex, dtradia, emis, temp_sol, rau, u, v, q_cdrag, vbeta, valpha, &
+     & vbeta1, qair, epot_air, psnew, qsurf, fluxsens, fluxlat, fluxsubli, vevapp, temp_sol_new, &
+     & lwdown, swnet, lwup, lwnet, pb, tsol_rad, netrad, evapot, evapot_corr)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size
+    REAL(r_std), INTENT(in)                                  :: dtradia       !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: emis          !! Emissivity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol      !! Soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau           !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u,v           !! wind
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag       !!
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: vbeta         !! Resistance coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: valpha        !! Resistance coefficient
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: vbeta1        !! Snow resistance 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair          !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: epot_air      !! Air potential energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: psnew         !! New surface static energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol_new  !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb            !! Lowest level pressure
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf         !! Surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsens      !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxlat       !! Latent chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsubli     !! Energy of sublimation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp        !! Total of evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: lwdown        !! Downward Long-wave radiation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet         !! Net SW radiation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: lwup          !! Long-wave up radiation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: lwnet         !! Long-wave net radiation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad      !! Radiative surface temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: netrad        !! Net radiation 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: evapot        !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: evapot_corr   !! Soil Potential Evaporation Correction
+
+
+    ! local declaration
+    INTEGER(i_std)                                 :: ji
+    REAL(r_std),DIMENSION (kjpindex)                :: grad_qsat
+    REAL(r_std)                                     :: correction
+    REAL(r_std)                                     :: speed, qc
+    LOGICAL,DIMENSION (kjpindex)                   :: warning_correction
+    ! initialisation
+
+    !
+    ! 1. computes temp_sol_new, netrad, vevapp, fluxlat, fluxsubli, fluxsens 
+    !
+
+    DO ji=1,kjpindex
+
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+      qc = speed * q_cdrag(ji)
+
+      lwup(ji) = emis(ji) * c_stefan * temp_sol(ji)**4 + &
+           &     quatre * emis(ji) * c_stefan * temp_sol(ji)**3 * &
+           &     (temp_sol_new(ji) - temp_sol(ji)) 
+!!
+!!    Add the reflected LW radiation
+!!
+      lwup(ji) = lwup(ji)  +  (un - emis(ji)) * lwdown(ji)
+
+!!      tsol_rad(ji) =  (lwup(ji)/ (emis(ji) * c_stefan)) **(1./quatre)
+!!  Need to check the equations
+!!
+      tsol_rad(ji) = emis(ji) * c_stefan * temp_sol(ji)**4 + lwup(ji)
+!!
+!!  This is a simple diagnostic which will be used by the GCM to compute the dependence of
+!!  of the surface layer stability on moisture.
+!!
+      qsurf(ji) = vbeta1(ji) * qsol_sat_new(ji) + &
+           & (un - vbeta1(ji)) * vbeta(ji) * valpha(ji) * qsol_sat_new(ji)
+      qsurf(ji) = MAX(qsurf(ji), qair(ji))
+      
+      netrad(ji) = lwdown(ji) + swnet(ji) - lwup(ji) 
+
+      vevapp(ji) = dtradia * rau(ji) * qc * vbeta1(ji) * (qsol_sat_new(ji) - qair(ji)) + &
+           & dtradia * rau(ji) * qc * (un - vbeta1(ji)) * vbeta(ji) * &
+           & (valpha(ji) * qsol_sat_new(ji) - qair(ji))
+
+      fluxlat(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) *&
+           & (qsol_sat_new(ji) - qair(ji)) + &
+           &  chalev0 * rau(ji) * qc * (un - vbeta1(ji)) * vbeta(ji) * &
+           & (valpha(ji) * qsol_sat_new(ji) - qair(ji))
+
+      fluxsubli(ji) = chalsu0 * rau(ji) * qc * vbeta1(ji) *&
+           & (qsol_sat_new(ji) - qair(ji)) 
+
+      fluxsens(ji) =  rau(ji) * qc * (psnew(ji) - epot_air(ji))
+
+      lwnet(ji) = lwdown(ji) - lwup(ji)
+  
+      evapot(ji) =  MAX(zero, dtradia * rau(ji) * qc * (qsol_sat_new(ji) - qair(ji)))
+
+      tair(ji)  =  epot_air(ji) / cp_air
+
+     ENDDO 
+
+! define qsat_air avec subroutine de src_parameter:
+
+    CALL qsatcalc(kjpindex, tair, pb, qsat_air)
+
+    CALL dev_qsatcalc(kjpindex, tair, pb, grad_qsat)
+!    grad_qsat(:)= (qsol_sat_new(:)- qsat_air(:)) / ((psnew(:) - epot_air(:)) / cp_air) ! * dtradia
+    !- Penser a sortir evapot en meme temps qu'evapot_corr tdo.
+    warning_correction(:)=.FALSE.
+    DO ji=1,kjpindex
+
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+      qc = speed * q_cdrag(ji)
+
+       IF ((evapot(ji) .GT. zero) .AND. ((psnew(ji) - epot_air(ji)) .NE. zero )) THEN
+
+          correction =  (quatre * emis(ji) * c_stefan * tair(ji)**3 + rau(ji) * qc * cp_air + &
+               &                  chalev0 * rau(ji) * qc * grad_qsat(ji) * vevapp(ji) / evapot(ji) )
+          IF (ABS(correction) .GT. min_sechiba) THEN
+             correction = chalev0 * rau(ji) * qc * grad_qsat(ji) * (un - vevapp(ji)/evapot(ji)) / correction
+          ELSE
+             warning_correction(ji)=.TRUE.
+          ENDIF
+       ELSE
+          correction = zero
+       ENDIF
+       correction = MAX (zero, correction)
+       
+       evapot_corr(ji) = evapot(ji) / (un + correction)
+       
+    ENDDO
+    IF ( ANY(warning_correction) ) THEN
+       DO ji=1,kjpindex
+          IF ( warning_correction(ji) ) THEN
+             WRITE(numout,*) ji,"Denominateur de la correction de milly nul! Aucune correction appliquee"
+          ENDIF
+       ENDDO
+    ENDIF
+    IF (long_print) WRITE (numout,*) ' enerbil_flux done '
+
+  END SUBROUTINE enerbil_flux
+
+  !! This routine computes evaporation and transpiration
+  !!
+  SUBROUTINE enerbil_evapveg (kjpindex, dtradia, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, cimean, &
+     & ccanopy, rau, u, v, q_cdrag, qair, humrel, vevapsno, vevapnu , vevapwet, transpir, gpp, evapot)
+
+    ! interface description
+    ! input scalar
+    INTEGER(i_std), INTENT(in)                               :: kjpindex          !! Domain size
+    REAL(r_std), INTENT(in)                                  :: dtradia           !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: vbeta1           !! Snow resistance 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: vbeta4           !! Bare soil resistance
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: rau              !! Density
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u, v             !! Wind
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q_cdrag          !!
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair             !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: ccanopy          !! CO2 concentration in the canopy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: evapot           !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex, nvm), INTENT (in)       :: humrel           !! Relative humidity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta2           !! Interception resistance
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbeta3           !! Vegetation resistance
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: vbetaco2         !! Vegetation resistance to CO2
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: cimean           !! mean Ci
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapsno         !! Snow evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapnu          !! Bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: transpir         !! Transpiration
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: gpp              !! Assimilation, gC/m**2 total area.
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: vevapwet         !! Interception 
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std), DIMENSION(kjpindex)               :: xx
+    REAL(r_std)                                    :: speed
+
+    ! initialisation
+
+    ! 
+    ! 1. computes vevapsno, vevapnu
+    !
+
+    DO ji=1,kjpindex 
+
+      speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+
+      !
+      ! 1.1 snow sublimation
+      !
+      vevapsno(ji) = vbeta1(ji) * dtradia * rau(ji) * speed * q_cdrag(ji) * (qsol_sat_new(ji) - qair(ji))
+
+      !
+      ! 1.2 bare soil evaporation
+      !
+      vevapnu(ji) = (un - vbeta1(ji)) * vbeta4(ji) * dtradia * rau(ji) * speed * q_cdrag(ji) &
+         & * (qsol_sat_new(ji) - qair(ji))
+
+    END DO
+
+    !
+    ! 2. computes transpir and vevapwet
+    !
+
+    DO ji = 1, kjpindex
+       !
+       speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+       !
+       xx(ji) = dtradia * (un-vbeta1(ji)) * (qsol_sat_new(ji)-qair(ji)) * rau(ji) * speed * q_cdrag(ji)
+       !
+    ENDDO
+    !
+    DO jv=1,nvm 
+      DO ji=1,kjpindex 
+        !
+        ! 2.1 Interception loss
+        !
+        vevapwet(ji,jv) = xx(ji) * vbeta2(ji,jv)
+        ! 
+        ! 2.2 Transpiration
+        !
+        transpir (ji,jv) = xx(ji) * vbeta3(ji,jv)
+        !
+      END DO
+    END DO
+
+    !
+    ! 3 STOMATE: Assimilation
+    !
+
+    IF ( control%ok_co2 ) THEN
+
+      DO jv = 1, nvm
+         DO ji = 1, kjpindex
+        speed = MAX(min_wind, SQRT (u(ji)*u(ji) + v(ji)*v(ji)))
+
+        gpp(ji,jv) = vbetaco2(ji,jv) * dtradia * rau(ji) * speed * q_cdrag(ji) * &
+                    (ccanopy(ji) - cimean(ji,jv)) * 12.e-6
+        ENDDO
+      ENDDO
+
+    ELSEIF ( control%stomate_watchout ) THEN
+
+      gpp(:,:) = zero
+
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' enerbil_evapveg done '
+
+  END SUBROUTINE enerbil_evapveg
+
+  !! Second part of main routine for enerbil module
+  !! - called every time step
+  !!
+  !! Algorithm:
+  !! computes new soil temperature due to ice and snow melt
+  !!
+  SUBROUTINE enerbil_fusion (kjpindex, dtradia, tot_melt, soilcap, temp_sol_new, fusion )
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex       !! Domain size
+    REAL(r_std), INTENT(in)                                  :: dtradia        !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: tot_melt       !! Total melt
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: soilcap        !! Soil calorific capacity
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: temp_sol_new   !! New soil temperature
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fusion         !! Fusion
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji
+
+    ! initialisation
+    IF (long_print) WRITE (numout,*) ' enerbil_fusion start ', MINVAL(soilcap), MINLOC(soilcap),&
+         & MAXVAL(soilcap), MAXLOC(soilcap)
+    !
+    ! 1. computes new soil temperature due to ice and snow melt
+    !
+    DO ji=1,kjpindex 
+
+      fusion(ji) = tot_melt(ji) * chalfu0 / dtradia
+
+      temp_sol_new(ji) = temp_sol_new(ji) - ((tot_melt(ji) * chalfu0) / soilcap(ji))
+
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' enerbil_fusion done '
+
+  END SUBROUTINE enerbil_fusion
+
+  !! Diagnose 2 meter air temperature
+  !!
+  SUBROUTINE enerbil_t2mdiag (kjpindex, temp_air, t2mdiag)
+
+    ! interface description
+    ! input scalar
+    INTEGER(i_std), INTENT(in)                         :: kjpindex       !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_air       !! Air temperature in Kelvin
+    ! modified fields
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: t2mdiag        !! 2-meter temperature
+
+    t2mdiag(:) = temp_air(:)
+
+    IF (long_print) WRITE (numout,*) ' enerbil_t2mdiag done '
+
+  END SUBROUTINE enerbil_t2mdiag
+
+END MODULE enerbil
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/hydrol.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/hydrol.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/hydrol.f90	(revision 55)
@@ -0,0 +1,3849 @@
+!!
+!! This module computes hydrologic processes on continental points.
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!!
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!!                                                           
+MODULE hydrol
+  !
+  !
+  ! routines called : restput, restget
+  !
+  USE ioipsl
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_soil
+  USE constantes_veg
+  USE sechiba_io
+
+  ! for debug :
+  USE grid
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! hydrol
+  PRIVATE
+  PUBLIC :: hydrol_main,hydrol_clear 
+
+  !
+  ! variables used inside hydrol module : declaration and initialisation
+  !
+  LOGICAL, SAVE                                     :: l_first_hydrol=.TRUE. !! Initialisation has to be done one time
+  !
+  LOGICAL, SAVE                                     :: check_waterbal=.TRUE. !! The check the water balance
+  LOGICAL, SAVE                                     :: check_cwrr=.TRUE. !! The check the water balance
+
+  CHARACTER(LEN=80) , SAVE                          :: file_ext         !! Extention for I/O filename
+  CHARACTER(LEN=80) , SAVE                          :: var_name         !! To store variables names for I/O
+  REAL(r_std), PARAMETER                             :: drain_rest_cste = 15.0  !! time constant in days to return to free drainage after return flow
+  REAL(r_std), PARAMETER                             :: allowed_err =  1.0E-8_r_std
+  REAL(r_std), PARAMETER                             :: dmcs = 0.002     !! Allowed moisture above mcs (boundary conditions)
+  REAL(r_std), PARAMETER                             :: dmcr = 0.002     !! Allowed moisture below mcr (boundary conditions)
+  ! one dimension array allocated, computed, saved and got in hydrol module
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_water_beg    !! Total amount of water at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_water_end    !! Total amount of water at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watveg_beg   !! Total amount of water on vegetation at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watveg_end   !! Total amount of water on vegetation at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watsoil_beg  !! Total amount of water in the soil at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watsoil_end  !! Total amount of water in the soil at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snow_beg         !! Total amount of snow at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snow_end         !! Total amount of snow at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delsoilmoist     !! Change in soil moisture
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delintercept     !! Change in interception storage
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delswe           !! Change in SWE^Q
+
+  ! array allocated, computed, saved and got in hydrol module
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: mask_veget           !! zero/one when veget fraction is zero/higher
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: mask_soiltype        !! zero/one where soil fraction is zero/higher 
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: mask_corr_veg_soil   !! zero/one where veg frac on a soil type is zero/higher
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: mask_return          !! zero/one where there is no/is returnflow
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: index_nsat           !! Indices of the non-saturated layers
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: index_sat            !! Indices of the saturated layers
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: n_nsat               !! Number of non-saturated layers
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: n_sat                !! Number of saturated layers
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: nslme                !! last efficient layer
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: humrelv          !! humrel for each soil type
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: vegstressv       !! vegstress for each soil type  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:,:):: us               !! relative humidity 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: precisol         !! Eau tombee sur le sol
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: precisol_ns      !! Eau tombee sur le sol par type de sol
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: ae_ns            !! Evaporation du sol nu par type de sol
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: evap_bare_lim_ns !! limitation of bare soil evaporation on each soil column (used to deconvoluate vevapnu)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: free_drain_coef !! Coefficient for free drainage at bottom
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: rootsink         !! stress racinaire par niveau et type de sol
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: subsnowveg       !! Sublimation of snow on vegetation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: subsnownobio     !! Sublimation of snow on other surface types (ice, lakes, ...)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snowmelt         !! Quantite de neige fondue
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: icemelt          !! Quantite de glace fondue
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: subsinksoil      !! Excess of sublimation as a sink for the soil
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: vegtot           !! Total  vegetation
+  ! The last vegetation map which was used to distribute the reservoirs
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: resdist          !! Distribution of reservoirs
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: mx_eau_var
+
+  ! arrays used by cwrr scheme
+  REAL(r_std), SAVE, DIMENSION (nslm+1,nstm)         :: zz               !! 
+  REAL(r_std), SAVE, DIMENSION (nslm+1,nstm)         :: dz               !! 
+  REAL(r_std), SAVE, DIMENSION (imin:imax,nstm)      :: mc_lin             !! 
+  REAL(r_std), SAVE, DIMENSION (nstm)      :: v1r             !! Residual soil water content of the first layer
+  REAL(r_std), SAVE, DIMENSION (nstm)      :: vBs             !! Saturated soil water content of the bottom layer
+
+  REAL(r_std), SAVE, DIMENSION (imin:imax,nstm)      :: k_lin               !! 
+  REAL(r_std), SAVE, DIMENSION (imin:imax,nstm)      :: d_lin               !! 
+  REAL(r_std), SAVE, DIMENSION (imin:imax,nstm)      :: a_lin              !! 
+  REAL(r_std), SAVE, DIMENSION (imin:imax,nstm)      :: b_lin               !! 
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: humtot      !! (:)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: flux        !! (:)
+  LOGICAL, ALLOCATABLE, SAVE, DIMENSION (:)         :: resolv      !! (:)
+
+
+!! linarization coefficients of hydraulic conductivity K
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: a           !! (:,nslm)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: b           !!
+!! linarization coefficients of hydraulic diffusivity D
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: d           !!
+
+!! matrix coefficients
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: e           !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: f           !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: g1          !!
+
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: ep          !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: fp          !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: gp          !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: rhs         !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: srhs        !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: gam         !!
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc         !! (:,nstm) Total moisture content (mm)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tmcs        !! (nstm) Total moisture constent at saturation (mm)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter       !! (:,nstm) Total moisture in the litter by soil type
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tmc_litt_mea !! Total moisture in the litter over the grid
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_wilt  !! (:,nstm) Moisture of litter at wilt pt
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_field !! (:,nstm) Moisture of litter at field cap.
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_res !! (:,nstm) Moisture of litter at residual moisture.
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_sat   !! (:,nstm) Moisture of litter at saturatiion
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_awet   !! (:,nstm) Moisture of litter at mc_awet
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tmc_litter_adry   !! (:,nstm) Moisture of litter at mc_dry
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tmc_litt_wet_mea !! Total moisture in the litter over the grid below which albedo is fixed
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:) :: tmc_litt_dry_mea !! Total moisture in the litter over the grid above which albedo is fixed
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: v1          !! (:)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: vB          !! (:)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: qflux00     !! flux at the top of the soil column
+
+  !! par type de sol :
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: ru_ns       !! ruissellement
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: dr_ns       !! drainage
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: tr_ns       !! transpiration 
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: corr_veg_soil !! (:,nvm,nstm)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: corr_veg_soil_max !! (:,nvm,nstm)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: mc          !! (:,nslm,nstm) m³ x m³
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: soilmoist     !! (:,nslm)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: soil_wet    !! soil wetness
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: soil_wet_litter !! soil wetness of the litter
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: qflux       !! fluxes between the soil layers
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: tmat        !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)  :: stmat        !!
+
+  LOGICAL, SAVE                                     :: interpol_diag=.FALSE.
+
+CONTAINS
+
+  !! 
+  !! Main routine for *hydrol* module
+  !! - called only one time for initialisation
+  !! - called every time step
+  !! - called one more time at last time step for writing _restart_ file
+  !!
+  !! Algorithm:
+  !! - call hydrol_snow for snow process (including age of snow)
+  !! - call hydrol_canop for canopy process
+  !! - call hydrol_soil for bare soil process
+  !!
+  !! @call hydrol_snow
+  !! @call hydrol_canop
+  !! @call hydrol_soil
+  !!
+  SUBROUTINE hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+       & index, indexveg, indexsoil, indexlayer,&
+       & temp_sol_new, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max, &
+       & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age,  &
+       & tot_melt, transpir, precip_rain, precip_snow, returnflow, irrigation, &
+       & humrel, vegstress, drysoil_frac, evapot, evapot_penm, evap_bare_lim, &
+       & shumdiag, litterhumdiag, soilcap, soiltype, rest_id, hist_id, hist2_id)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                         :: kjit             !! Time step number 
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size
+    INTEGER(i_std),INTENT (in)                         :: rest_id,hist_id  !! _Restart_ file and _history_ file identifier
+    INTEGER(i_std),INTENT (in)                         :: hist2_id         !! _history_ file 2 identifier
+    REAL(r_std), INTENT (in)                           :: dtradia          !! Time step in seconds
+    LOGICAL, INTENT(in)                               :: ldrestart_read   !! Logical for _restart_ file to read
+    LOGICAL, INTENT(in)                               :: ldrestart_write  !! Logical for _restart_ file to write
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: index            !! Indeces of the points on the map
+    INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in):: indexveg        !! Indeces of the points on the 3D map for veg
+    INTEGER(i_std),DIMENSION (kjpindex*nstm), INTENT (in):: indexsoil      !! Indeces of the points on the 3D map for soil
+    INTEGER(i_std),DIMENSION (kjpindex*nslm), INTENT (in):: indexlayer     !! Indeces of the points on the 3D map for soil layers
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_rain      !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_snow      !! Snow precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: returnflow       !! Routed water which comes back into the soil
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: irrigation        !! Water from irrigation returning to soil moisture  
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol_new     !! New soil temperature
+
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio     !! Fraction of ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: totfrac_nobio    !! Total fraction of ice+lakes+...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: soilcap          !! Soil capacity
+    REAL(r_std),DIMENSION (kjpindex,nstm), INTENT (in) :: soiltype         !! Map of soil types
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vevapwet         !! Interception loss
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget            !! Fraction of vegetation type           
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max        !! Max. fraction of vegetation type (LAI -> infty)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintmax         !! Maximum water on vegetation for interception
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: transpir         !! Transpiration
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot           !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot_penm      !! Soil Potential Evaporation Correction
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)      :: evap_bare_lim    !!
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: vevapnu          !! Bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: vevapsno         !! Snow evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: snow             !! Snow mass [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: snow_age         !! Snow age
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio     !! Water balance on ice, lakes, .. [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio_age !! Snow age on ice, lakes, ...
+    !! We consider that any water on the ice is snow and we only peforme a water balance to have consistency.
+    !! The water balance is limite to + or - 10^6 so that accumulation is not endless
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: runoff           !! Complete runoff
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: drainage         !! Drainage
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: humrel           !! Relative humidity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress        !! Veg. moisture stress (only for vegetation growth)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drysoil_frac     !! function of litter wetness
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout):: shumdiag         !! relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: litterhumdiag    !! litter humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: tot_melt         !! Total melt    
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: qsintveg         !! Water on vegetation due to interception
+
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                    :: jst, jsl
+    REAL(r_std),DIMENSION (kjpindex)                   :: soilwet          !! A temporary diagnostic of soil wetness
+    REAL(r_std),DIMENSION (kjpindex)                   :: snowdepth        !! Depth of snow layer
+    !
+    ! do initialisation
+    !
+    IF (l_first_hydrol) THEN
+
+       IF (long_print) WRITE (numout,*) ' l_first_hydrol : call hydrol_init '
+
+       CALL hydrol_init (kjit, ldrestart_read, kjpindex, index, rest_id, veget, soiltype, humrel,&
+            & vegstress, snow, snow_age, snow_nobio, snow_nobio_age, qsintveg) 
+       CALL hydrol_var_init (kjpindex, veget, soiltype, mx_eau_var, shumdiag, litterhumdiag, &
+            & drysoil_frac, evap_bare_lim) 
+       !
+       ! If we check the water balance we first save the total amount of water
+       !
+       IF (check_waterbal) THEN
+          CALL hydrol_waterbal(kjpindex, index, .TRUE., dtradia, veget, &
+               & totfrac_nobio, qsintveg, snow, snow_nobio,&
+               & precip_rain, precip_snow, returnflow, irrigation, tot_melt, &
+               & vevapwet, transpir, vevapnu, vevapsno, runoff,drainage)
+       ENDIF
+       !
+       IF (almaoutput) THEN
+          CALL hydrol_alma(kjpindex, index, .TRUE., qsintveg, snow, snow_nobio, soilwet)
+       ENDIF
+
+       RETURN
+
+    ENDIF
+
+    !
+    ! prepares restart file for the next simulation
+    !
+    IF (ldrestart_write) THEN
+
+       IF (long_print) WRITE (numout,*) ' we have to complete restart file with HYDROLOGIC variables '
+
+       DO jst=1,nstm
+          ! var_name= "mc_1" ... "mc_3"
+          WRITE (var_name,"('moistc_',i1)") jst
+          CALL restput_p(rest_id, var_name, nbp_glo,  nslm, 1, kjit, mc(:,:,jst), 'scatter',  nbp_glo, index_g)
+       END DO
+       !
+       DO jst=1,nstm
+          DO jsl=1,nslm
+             ! var_name= "us_1_01" ... "us_3_11"
+             WRITE (var_name,"('us_',i1,'_',i2.2)") jst,jsl
+             CALL restput_p(rest_id, var_name, nbp_glo,nvm, 1,kjit,us(:,:,jst,jsl),'scatter',nbp_glo,index_g)
+          END DO
+       END DO
+       !
+       var_name= 'free_drain_coef'  
+       CALL restput_p(rest_id, var_name, nbp_glo,   nstm, 1, kjit,  free_drain_coef, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'ae_ns'  
+       CALL restput_p(rest_id, var_name, nbp_glo,   nstm, 1, kjit,  ae_ns, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'vegstress'
+       CALL restput_p(rest_id, var_name, nbp_glo,   nvm, 1, kjit,  vegstress, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'snow'    
+       CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  snow, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'snow_age'
+       CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  snow_age, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'snow_nobio'    
+       CALL restput_p(rest_id, var_name, nbp_glo,   nnobio, 1, kjit,  snow_nobio, 'scatter', nbp_glo, index_g)
+       !
+       var_name= 'snow_nobio_age'
+       CALL restput_p(rest_id, var_name, nbp_glo,   nnobio, 1, kjit,  snow_nobio_age, 'scatter', nbp_glo, index_g)
+       !
+       var_name= 'qsintveg'
+       CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit,  qsintveg, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'resdist'
+       CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit,  resdist, 'scatter',  nbp_glo, index_g)       
+       RETURN
+       !
+    END IF
+
+    !
+    ! shared time step
+    !
+    IF (long_print) WRITE (numout,*) 'hydrol pas de temps = ',dtradia
+
+    ! 
+    ! computes snow
+    !
+
+    CALL hydrol_snow(kjpindex, dtradia, precip_rain, precip_snow, temp_sol_new, soilcap, &
+         & frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
+         & tot_melt, snowdepth)
+
+    !
+    ! computes canopy
+    !
+    !
+    CALL hydrol_vegupd(kjpindex, veget, veget_max, soiltype, qsintveg,resdist)
+    !
+
+    CALL hydrol_canop(kjpindex, precip_rain, vevapwet, veget, qsintmax, qsintveg,precisol,tot_melt)
+
+    ! computes hydro_soil
+    !
+
+    CALL hydrol_soil(kjpindex, dtradia, veget, veget_max, soiltype, transpir, vevapnu, evapot, &
+         & evapot_penm, runoff, drainage, returnflow, irrigation, &
+         & tot_melt,evap_bare_lim, shumdiag, litterhumdiag, humrel, vegstress, drysoil_frac)
+    !
+    ! If we check the water balance we end with the comparison of total water change and fluxes
+    !
+    IF (check_waterbal) THEN
+       CALL hydrol_waterbal(kjpindex, index, .FALSE., dtradia, veget, totfrac_nobio, &
+            & qsintveg, snow,snow_nobio, precip_rain, precip_snow, returnflow, &
+            & irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno, runoff, drainage)
+    ENDIF
+    !
+    ! If we use the ALMA standards
+    !
+    IF (almaoutput) THEN
+       CALL hydrol_alma(kjpindex, index, .FALSE., qsintveg, snow, snow_nobio, soilwet)
+    ENDIF
+
+    !
+    IF ( .NOT. almaoutput ) THEN
+       DO jst=1,nstm
+          ! var_name= "mc_1" ... "mc_3"
+          WRITE (var_name,"('moistc_',i1)") jst
+          CALL histwrite(hist_id, trim(var_name), kjit,mc(:,:,jst), kjpindex*nslm, indexlayer)
+
+          ! var_name= "vegetsoil_1" ... "vegetsoil_3"
+          WRITE (var_name,"('vegetsoil_',i1)") jst
+          CALL histwrite(hist_id, trim(var_name), kjit,corr_veg_soil(:,:,jst), kjpindex*nvm, indexveg)
+       ENDDO
+       CALL histwrite(hist_id, 'evapnu_soil', kjit, ae_ns, kjpindex*nstm, indexsoil)
+       CALL histwrite(hist_id, 'drainage_soil', kjit, dr_ns, kjpindex*nstm, indexsoil)
+       CALL histwrite(hist_id, 'transpir_soil', kjit, tr_ns, kjpindex*nstm, indexsoil)
+       CALL histwrite(hist_id, 'runoff_soil', kjit, ru_ns, kjpindex*nstm, indexsoil)
+       CALL histwrite(hist_id, 'humtot_soil', kjit, tmc, kjpindex*nstm, indexsoil)
+       CALL histwrite(hist_id, 'humtot', kjit, humtot, kjpindex, index)
+       CALL histwrite(hist_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'drainage', kjit, drainage, kjpindex, index)
+       CALL histwrite(hist_id, 'runoff', kjit, runoff, kjpindex, index)
+       CALL histwrite(hist_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'rain', kjit, precip_rain, kjpindex, index)
+       CALL histwrite(hist_id, 'snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite(hist_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+       IF ( hist2_id > 0 ) THEN
+          DO jst=1,nstm
+             ! var_name= "mc_1" ... "mc_3"
+             WRITE (var_name,"('moistc_',i1)") jst
+             CALL histwrite(hist2_id, trim(var_name), kjit,mc(:,:,jst), kjpindex*nslm, indexlayer)
+
+             ! var_name= "vegetsoil_1" ... "vegetsoil_3"
+             WRITE (var_name,"('vegetsoil_',i1)") jst
+             CALL histwrite(hist2_id, trim(var_name), kjit,corr_veg_soil(:,:,jst), kjpindex*nvm, indexveg)
+          ENDDO
+          CALL histwrite(hist2_id, 'evapnu_soil', kjit, ae_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite(hist2_id, 'drainage_soil', kjit, dr_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite(hist2_id, 'transpir_soil', kjit, tr_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite(hist2_id, 'runoff_soil', kjit, ru_ns, kjpindex*nstm, indexsoil)
+          CALL histwrite(hist2_id, 'humtot_soil', kjit, tmc, kjpindex*nstm, indexsoil)
+          CALL histwrite(hist2_id, 'humtot', kjit, humtot, kjpindex, index)
+          CALL histwrite(hist2_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'drainage', kjit, drainage, kjpindex, index)
+          CALL histwrite(hist2_id, 'runoff', kjit, runoff, kjpindex, index)
+          CALL histwrite(hist2_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'rain', kjit, precip_rain, kjpindex, index)
+          CALL histwrite(hist2_id, 'snowf', kjit, precip_snow, kjpindex, index)
+          CALL histwrite(hist2_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+       ENDIF
+    ELSE
+       CALL histwrite(hist_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite(hist_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+       CALL histwrite(hist_id, 'Qs', kjit, runoff, kjpindex, index)
+       CALL histwrite(hist_id, 'Qsb', kjit, drainage, kjpindex, index)
+       CALL histwrite(hist_id, 'Qsm', kjit, tot_melt, kjpindex, index)
+       CALL histwrite(hist_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+       CALL histwrite(hist_id, 'DelSWE', kjit, delswe, kjpindex, index)
+       CALL histwrite(hist_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
+       !
+       CALL histwrite(hist_id, 'SoilMoist', kjit, soilmoist, kjpindex*nslm, indexlayer)
+       CALL histwrite(hist_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+       !
+       CALL histwrite(hist_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+       CALL histwrite(hist_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+       !
+       CALL histwrite(hist_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+       !
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+          CALL histwrite(hist2_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+          CALL histwrite(hist2_id, 'Qs', kjit, runoff, kjpindex, index)
+          CALL histwrite(hist2_id, 'Qsb', kjit, drainage, kjpindex, index)
+          CALL histwrite(hist2_id, 'Qsm', kjit, tot_melt, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelSWE', kjit, delswe, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
+          !
+          CALL histwrite(hist2_id, 'SoilMoist', kjit, soilmoist, kjpindex*nslm, indexlayer)
+          CALL histwrite(hist2_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+          !
+          CALL histwrite(hist2_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+          CALL histwrite(hist2_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+          !
+          CALL histwrite(hist2_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+       ENDIF
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' hydrol_main Done '
+
+  END SUBROUTINE hydrol_main
+
+  !! Algorithm:
+  !! - dynamic allocation for local array 
+  !! - _restart_ file reading for HYDROLOGIC variables
+  !!
+  SUBROUTINE hydrol_init(kjit, ldrestart_read, kjpindex, index, rest_id, veget, soiltype, humrel,&
+       &  vegstress, snow, snow_age, snow_nobio, snow_nobio_age, qsintveg)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                         :: kjit               !! Time step number 
+    LOGICAL,INTENT (in)                                :: ldrestart_read     !! Logical for _restart_ file to read
+    INTEGER(i_std), INTENT (in)                         :: kjpindex           !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: index              !! Indeces of the points on the map
+    INTEGER(i_std), INTENT (in)                         :: rest_id            !! _Restart_ file identifier 
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: veget              !! Carte de vegetation
+    REAL(r_std),DIMENSION (kjpindex,nstm), INTENT (in)  :: soiltype         !! Map of soil types
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: humrel             !! Stress hydrique, relative humidity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress     !! Veg. moisture stress (only for vegetation growth)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: snow               !! Snow mass [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: snow_age           !! Snow age
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio       !! Snow on ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio_age   !! Snow age on ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: qsintveg           !! Water on vegetation due to interception
+
+    ! local declaration
+    INTEGER(i_std)                                     :: ier, ierror, ipdt
+    INTEGER(i_std)                                     :: ji, jv, jst, jsl, ik
+
+    ! initialisation
+    IF (l_first_hydrol) THEN 
+       l_first_hydrol=.FALSE.
+    ELSE 
+       WRITE (numout,*) ' l_first_hydrol false . we stop '
+       STOP 'hydrol_init'
+    ENDIF
+
+    ! make dynamic allocation with good dimension
+
+    ! one dimension array allocation with possible restart value
+
+    ALLOCATE (mask_corr_veg_soil(kjpindex,nvm,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in  mask_corr_veg_soil allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (mask_veget(kjpindex,nvm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_veget allocation. We stop. We need kjpindex words = ',kjpindex*nvm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (mask_soiltype(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_soiltype allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (mask_return(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_soiltype allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (index_nsat(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_soiltype allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (index_sat(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_soiltype allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (n_nsat(nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_soiltype allocation. We stop. We need kjpindex words = ',nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (n_sat(nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_soiltype allocation. We stop. We need kjpindex words = ',nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (nslme(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mask_soiltype allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (humrelv(kjpindex,nvm,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in humrelv allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (vegstressv(kjpindex,nvm,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vegstressv allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (us(kjpindex,nvm,nstm,nslm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in us allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (precisol(kjpindex,nvm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in precisol allocation. We stop. We need kjpindex words = ',kjpindex*nvm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (precisol_ns(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in precisol_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (free_drain_coef(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in free_drain_coef allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (ae_ns(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in ae_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (evap_bare_lim_ns(kjpindex,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in evap_bare_lim_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (rootsink(kjpindex,nslm,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in rootsink allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (subsnowveg(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in subsnowveg allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (subsnownobio(kjpindex,nnobio),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in subsnownobio allocation. We stop. We need kjpindex words = ',kjpindex*nnobio
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (snowmelt(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in snowmelt allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (icemelt(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in icemelt allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (subsinksoil(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in subsinksoil allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (mx_eau_var(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mx_eau_var allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (vegtot(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vegtot allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (resdist(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in resdist allocation. We stop. We need kjpindex words = ',kjpindex*nvm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (humtot(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in humtot allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (flux(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in flux allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (resolv(kjpindex),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in resolv allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (a(kjpindex,nslm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in a allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (b(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in b allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (d(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in d allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (e(kjpindex,nslm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in e allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (f(kjpindex,nslm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in f allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (g1(kjpindex,nslm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in g1 allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (ep(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in ep allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (fp(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in fp allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (gp(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in gp allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (rhs(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in rhs allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (srhs(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in srhs allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (gam(kjpindex,nslm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in gam allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmcs(nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmcs allocation. We stop. We need kjpindex words = ',nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litter(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litter allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litt_mea(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litt_mea allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litter_res(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litter_res allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litter_wilt(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litter_wilt allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litter_field(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litter_field allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litter_sat(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litter_sat allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litter_awet(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litter_awet allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litter_adry(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litter_adry allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litt_wet_mea(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litt_wet_mea allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmc_litt_dry_mea(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmc_litt_dry_mea allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (v1(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in v1 allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (vB(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vB allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (qflux00(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in qflux00 allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (ru_ns(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in ru_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+    ru_ns(:,:) = zero
+
+    ALLOCATE (dr_ns(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in dr_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+    dr_ns(:,:) = zero
+
+    ALLOCATE (tr_ns(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tr_ns allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (corr_veg_soil(kjpindex,nvm,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in corr_veg_soil allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (corr_veg_soil_max(kjpindex,nvm,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in corr_veg_soil_max allocation. We stop. We need kjpindex words = ',kjpindex*nvm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+
+    ALLOCATE (mc(kjpindex,nslm,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in mc allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (soilmoist(kjpindex,nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in soilmoist allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (soil_wet(kjpindex,nslm,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in soil_wet allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (soil_wet_litter(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in soil_wet allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (qflux(kjpindex,nslm,nstm),stat=ier) 
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in qflux allocation. We stop. We need kjpindex words = ',kjpindex*nslm*nstm
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (tmat(kjpindex,nslm,3),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tmat allocation. We stop. We need kjpindex words = ',kjpindex*nslm*trois
+       STOP 'hydrol_init'
+    END IF
+
+    ALLOCATE (stmat(kjpindex,nslm,3),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in stmat allocation. We stop. We need kjpindex words = ',kjpindex*nslm*trois
+       STOP 'hydrol_init'
+    END IF
+
+    !
+    !  If we check the water balance we need two more variables
+    !
+    IF ( check_waterbal ) THEN
+
+       ALLOCATE (tot_water_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_water_beg allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (tot_water_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_water_end allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+    ENDIF
+    !
+    !  If we use the almaoutputs we need four more variables
+    !
+    IF ( almaoutput ) THEN
+
+       ALLOCATE (tot_watveg_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watveg_beg allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (tot_watveg_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watveg_end allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (tot_watsoil_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watsoil_beg allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (tot_watsoil_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watsoil_end allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (delsoilmoist(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in delsoilmoist allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (delintercept(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in delintercept. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (delswe(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in delswe. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrol_init'
+       ENDIF
+
+       ALLOCATE (snow_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in snow_beg allocation. We stop. We need kjpindex words =',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+       ALLOCATE (snow_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in snow_end allocation. We stop. We need kjpindex words =',kjpindex
+          STOP 'hydrol_init'
+       END IF
+
+    ENDIF
+
+    ! open restart input file done by sechiba_init
+    ! and read data from restart input file for HYDROLOGIC process
+
+    IF (ldrestart_read) THEN
+
+       IF (long_print) WRITE (numout,*) ' we have to read a restart file for HYDROLOGIC variables'
+
+       IF (is_root_prc) CALL ioconf_setatt('UNITS', '-')
+       !
+       DO jst=1,nstm
+          ! var_name= "mc_1" ... "mc_3"
+           WRITE (var_name,"('moistc_',I1)") jst
+           CALL ioconf_setatt('LONG_NAME',var_name)
+           CALL restget_p (rest_id, var_name, nbp_glo, nslm , 1, kjit, .TRUE., mc(:,:,jst), "gather", nbp_glo, index_g)
+       END DO
+       !
+       CALL ioconf_setatt('UNITS', '-')
+       DO jst=1,nstm
+          DO jsl=1,nslm
+             ! var_name= "us_1_01" ... "us_3_11"
+             WRITE (var_name,"('us_',i1,'_',i2.2)") jst,jsl
+             CALL ioconf_setatt('LONG_NAME',var_name)
+             CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., us(:,:,jst,jsl), "gather", nbp_glo, index_g)
+          END DO
+       END DO
+       !
+       var_name= 'free_drain_coef'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Coefficient for free drainage at bottom of soil')
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., free_drain_coef, "gather", nbp_glo, index_g)
+       !
+       var_name= 'ae_ns'
+       CALL ioconf_setatt('UNITS', 'kg/m^2')
+       CALL ioconf_setatt('LONG_NAME','Bare soil evap on each soil type')
+       CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., ae_ns, "gather", nbp_glo, index_g)
+       !
+       var_name= 'snow'        
+       CALL ioconf_setatt('UNITS', 'kg/m^2')
+       CALL ioconf_setatt('LONG_NAME','Snow mass')
+       CALL restget_p (rest_id, var_name, nbp_glo, 1  , 1, kjit, .TRUE., snow, "gather", nbp_glo, index_g)
+       !
+       var_name= 'snow_age'
+       CALL ioconf_setatt('UNITS', 'd')
+       CALL ioconf_setatt('LONG_NAME','Snow age')
+       CALL restget_p (rest_id, var_name, nbp_glo, 1  , 1, kjit, .TRUE., snow_age, "gather", nbp_glo, index_g)
+       !
+       var_name= 'snow_nobio'
+       CALL ioconf_setatt('UNITS', 'kg/m^2')
+       CALL ioconf_setatt('LONG_NAME','Snow on other surface types')
+       CALL restget_p (rest_id, var_name, nbp_glo, nnobio  , 1, kjit, .TRUE., snow_nobio, "gather", nbp_glo, index_g)
+       !
+       var_name= 'snow_nobio_age'
+       CALL ioconf_setatt('UNITS', 'd')
+       CALL ioconf_setatt('LONG_NAME','Snow age on other surface types')
+       CALL restget_p (rest_id, var_name, nbp_glo, nnobio  , 1, kjit, .TRUE., snow_nobio_age, "gather", nbp_glo, index_g)
+       !
+       var_name= 'vegstress'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Vegetation growth moisture stress')
+       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., vegstress, "gather", nbp_glo, index_g)
+       !
+       var_name= 'qsintveg'
+       CALL ioconf_setatt('UNITS', 'kg/m^2')
+       CALL ioconf_setatt('LONG_NAME','Intercepted moisture')
+       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., qsintveg, "gather", nbp_glo, index_g)
+       !
+       var_name= 'resdist'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Distribution of reservoirs')
+       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., resdist, "gather", nbp_glo, index_g)
+       !
+       !
+       !
+       ! get restart values if non were found in the restart file
+       !
+       !Config Key  = HYDROL_MOISTURE_CONTENT
+       !Config Desc = Soil moisture on each soil tile and levels
+       !Config Def  = 0.3
+       !Config Help = The initial value of mc if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       CALL setvar_p (mc, val_exp, 'HYDROL_MOISTURE_CONTENT', 0.3_r_std)
+       !
+       !Config Key  = US_INIT
+       !Config Desc = US_NVM_NSTM_NSLM
+       !Config Def  = 0.0
+       !Config Help = The initial value of us if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       DO jsl=1,nslm
+          CALL setvar_p (us(:,:,:,jsl), val_exp, 'US_INIT', zero)
+       ENDDO
+       !
+       !Config Key  = FREE_DRAIN_COEF
+       !Config Desc = Coefficient for free drainage at bottom
+       !Config Def  = 1.0, 1.0, 1.0
+       !Config Help = The initial value of free drainage if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       CALL setvar_p (free_drain_coef, val_exp, 'FREE_DRAIN_COEF', free_drain_max)
+       !
+       !Config Key  = EVAPNU_SOIL
+       !Config Desc = Bare soil evap on each soil if not found in restart
+       !Config Def  = 0.0
+       !Config Help = The initial value of bare soils evap if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       CALL setvar_p (ae_ns, val_exp, 'EVAPNU_SOIL', zero)
+       !
+       !Config Key  = HYDROL_SNOW
+       !Config Desc = Initial snow mass if not found in restart
+       !Config Def  = 0.0
+       !Config Help = The initial value of snow mass if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', zero)
+       !
+       !Config Key  = HYDROL_SNOWAGE
+       !Config Desc = Initial snow age if not found in restart
+       !Config Def  = 0.0
+       !Config Help = The initial value of snow age if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', zero)
+       !
+       !Config Key  = HYDROL_SNOW_NOBIO
+       !Config Desc = Initial snow amount on ice, lakes, etc. if not found in restart
+       !Config Def  = 0.0
+       !Config Help = The initial value of snow if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', zero)
+       !
+       !Config Key  = HYDROL_SNOW_NOBIO_AGE
+       !Config Desc = Initial snow age on ice, lakes, etc. if not found in restart
+       !Config Def  = 0.0
+       !Config Help = The initial value of snow age if its value is not found
+       !Config        in the restart file. This should only be used if the model is 
+       !Config        started without a restart file.
+       !
+       CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', zero)
+       !
+       !
+       !
+       !Config Key  = HYDROL_QSV
+       !Config Desc = Initial water on canopy if not found in restart
+       !Config Def  = 0.0
+       !Config Help = The initial value of moisture on canopy if its value 
+       !Config        is not found in the restart file. This should only be used if
+       !Config        the model is started without a restart file. 
+       !
+       CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', zero)
+       !
+       ! There is no need to configure the initialisation of resdist. If not available it is the vegetation map
+       !
+       IF ( MINVAL(resdist) .EQ.  MAXVAL(resdist) .AND. MINVAL(resdist) .EQ. val_exp) THEN
+          resdist = veget
+       ENDIF
+       !
+       !  Remember that it is only frac_nobio + SUM(veget(,:)) that is equal to 1. Thus we need vegtot
+       !
+       DO ji = 1, kjpindex
+          vegtot(ji) = SUM(veget(ji,:))
+       ENDDO
+       !
+       !
+       ! compute the masks for veget
+
+!       mask_veget(:,:) = MIN( un, MAX(zero,veget(:,:)))
+!       mask_soiltype(:,:) = MIN( un, MAX(zero,soiltype(:,:)))
+!       mask_corr_veg_soil(:,:,:) = MIN( un, MAX(zero,corr_veg_soil(:,:,:)))
+
+       mask_veget(:,:) = 0
+       mask_soiltype(:,:) = 0
+       mask_corr_veg_soil(:,:,:) = 0
+
+       mask_return(:) = 0
+       index_nsat(:,:) = 0
+       index_sat(:,:) = 0
+       n_nsat(:) = 1
+       n_sat(:) = 0
+       nslme(:,:) = nslm
+
+       DO ji = 1, kjpindex
+                    
+          DO jst = 1, nstm
+             IF(soiltype(ji,jst) .GT. min_sechiba) THEN
+                mask_soiltype(ji,jst) = 1
+             ENDIF
+          END DO
+          
+          DO jv = 1, nvm
+             IF(veget(ji,jv) .GT. min_sechiba) THEN
+                mask_veget(ji,jv) = 1
+             ENDIF
+
+             DO jst = 1, nstm
+                IF(corr_veg_soil(ji,jv,jst) .GT. min_sechiba) THEN
+                   mask_corr_veg_soil(ji,jv,jst) = 1
+                ENDIF
+             END DO
+          END DO
+          
+!      WRITE(numout,*) 'mask: soiltype,mask_soiltype',soiltype(ji,:),mask_soiltype(ji,:)
+
+       END DO
+       ! set humrelv from us
+
+       humrelv(:,:,:) = SUM(us,dim=4)
+       vegstressv(:,:,:) = SUM(us,dim=4)
+       ! set humrel from humrelv
+
+       humrel(:,:) = zero
+
+       DO jst=1,nstm
+          DO jv=1,nvm
+             DO ji=1,kjpindex
+
+                vegstress(ji,jv)=vegstress(ji,jv) + vegstressv(ji,jv,jst) * soiltype(ji,jst)
+
+!                IF(veget(ji,jv).NE.zero) THEN
+                   humrel(ji,jv)=humrel(ji,jv) + humrelv(ji,jv,jst) * & 
+                        & soiltype(ji,jst)
+                   humrel(ji,jv)=MAX(humrel(ji,jv), zero)* mask_veget(ji,jv)           
+!                ELSE
+!                   humrel(ji,jv)= zero
+!                ENDIF
+             END DO
+          END DO
+       END DO
+!       vegstress(:,:)=humrel(:,:)
+    ENDIF
+    !
+    !
+    IF (long_print) WRITE (numout,*) ' hydrol_init done '
+    !
+  END SUBROUTINE hydrol_init
+  !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+  SUBROUTINE hydrol_clear()
+
+    l_first_hydrol=.TRUE.
+    IF (ALLOCATED (mask_veget)) DEALLOCATE (mask_veget)
+    IF (ALLOCATED (mask_soiltype)) DEALLOCATE (mask_soiltype)
+    IF (ALLOCATED (mask_corr_veg_soil)) DEALLOCATE (mask_corr_veg_soil)
+    IF (ALLOCATED (mask_return)) DEALLOCATE (mask_return)
+    IF (ALLOCATED (index_nsat)) DEALLOCATE (index_nsat)
+    IF (ALLOCATED (index_sat)) DEALLOCATE (index_sat)
+    IF (ALLOCATED (n_nsat)) DEALLOCATE (n_nsat)
+    IF (ALLOCATED (n_sat)) DEALLOCATE (n_sat)
+    IF (ALLOCATED (nslme)) DEALLOCATE (nslme)
+    IF (ALLOCATED (humrelv)) DEALLOCATE (humrelv)
+    IF (ALLOCATED (vegstressv)) DEALLOCATE (vegstressv)
+    IF (ALLOCATED (us)) DEALLOCATE (us)
+    IF (ALLOCATED  (precisol)) DEALLOCATE (precisol)
+    IF (ALLOCATED  (precisol_ns)) DEALLOCATE (precisol_ns)
+    IF (ALLOCATED  (free_drain_coef)) DEALLOCATE (free_drain_coef)
+    IF (ALLOCATED  (ae_ns)) DEALLOCATE (ae_ns)
+    IF (ALLOCATED  (evap_bare_lim_ns)) DEALLOCATE (evap_bare_lim_ns)
+    IF (ALLOCATED  (rootsink)) DEALLOCATE (rootsink)
+    IF (ALLOCATED  (subsnowveg)) DEALLOCATE (subsnowveg)
+    IF (ALLOCATED  (subsnownobio)) DEALLOCATE (subsnownobio)
+    IF (ALLOCATED  (snowmelt)) DEALLOCATE (snowmelt)
+    IF (ALLOCATED  (icemelt)) DEALLOCATE (icemelt)
+    IF (ALLOCATED  (subsinksoil)) DEALLOCATE (subsinksoil)
+    IF (ALLOCATED  (mx_eau_var)) DEALLOCATE (mx_eau_var)
+    IF (ALLOCATED  (vegtot)) DEALLOCATE (vegtot)
+    IF (ALLOCATED  (resdist)) DEALLOCATE (resdist)
+    IF (ALLOCATED  (tot_water_beg)) DEALLOCATE (tot_water_beg)
+    IF (ALLOCATED  (tot_water_end)) DEALLOCATE (tot_water_end)
+    IF (ALLOCATED  (tot_watveg_beg)) DEALLOCATE (tot_watveg_beg)
+    IF (ALLOCATED  (tot_watveg_end)) DEALLOCATE (tot_watveg_end)
+    IF (ALLOCATED  (tot_watsoil_beg)) DEALLOCATE (tot_watsoil_beg)
+    IF (ALLOCATED  (tot_watsoil_end)) DEALLOCATE (tot_watsoil_end)
+    IF (ALLOCATED  (delsoilmoist)) DEALLOCATE (delsoilmoist)
+    IF (ALLOCATED  (delintercept)) DEALLOCATE (delintercept)
+    IF (ALLOCATED  (snow_beg)) DEALLOCATE (snow_beg)
+    IF (ALLOCATED  (snow_end)) DEALLOCATE (snow_end)
+    IF (ALLOCATED  (delswe)) DEALLOCATE (delswe)
+    ! more allocation for cwrr scheme
+    IF (ALLOCATED  (v1)) DEALLOCATE (v1)
+    IF (ALLOCATED  (vB)) DEALLOCATE (vB)
+    IF (ALLOCATED  (humtot)) DEALLOCATE (humtot)
+    IF (ALLOCATED  (flux)) DEALLOCATE (flux)
+    IF (ALLOCATED  (resolv)) DEALLOCATE (resolv)
+    IF (ALLOCATED  (a)) DEALLOCATE (a)
+    IF (ALLOCATED  (b)) DEALLOCATE (b)
+    IF (ALLOCATED  (d)) DEALLOCATE (d)
+    IF (ALLOCATED  (e)) DEALLOCATE (e)
+    IF (ALLOCATED  (f)) DEALLOCATE (f)
+    IF (ALLOCATED  (g1)) DEALLOCATE (g1)
+    IF (ALLOCATED  (ep)) DEALLOCATE (ep)
+    IF (ALLOCATED  (fp)) DEALLOCATE (fp)
+    IF (ALLOCATED  (gp)) DEALLOCATE (gp)
+    IF (ALLOCATED  (rhs)) DEALLOCATE (rhs)
+    IF (ALLOCATED  (srhs)) DEALLOCATE (srhs)
+    IF (ALLOCATED  (gam)) DEALLOCATE (gam)
+    IF (ALLOCATED  (tmc)) DEALLOCATE (tmc)
+    IF (ALLOCATED  (tmcs)) DEALLOCATE (tmcs)
+    IF (ALLOCATED  (tmc_litter)) DEALLOCATE (tmc_litter)
+    IF (ALLOCATED  (tmc_litt_mea)) DEALLOCATE (tmc_litt_mea)
+    IF (ALLOCATED  (tmc_litter_res)) DEALLOCATE (tmc_litter_res)
+    IF (ALLOCATED  (tmc_litter_wilt)) DEALLOCATE (tmc_litter_wilt)
+    IF (ALLOCATED  (tmc_litter_field)) DEALLOCATE (tmc_litter_field)
+    IF (ALLOCATED  (tmc_litter_sat)) DEALLOCATE (tmc_litter_sat)
+    IF (ALLOCATED  (tmc_litter_awet)) DEALLOCATE (tmc_litter_awet)
+    IF (ALLOCATED  (tmc_litter_adry)) DEALLOCATE (tmc_litter_adry)
+    IF (ALLOCATED  (tmc_litt_wet_mea)) DEALLOCATE (tmc_litt_wet_mea)
+    IF (ALLOCATED  (tmc_litt_dry_mea)) DEALLOCATE (tmc_litt_dry_mea)
+    IF (ALLOCATED  (qflux00)) DEALLOCATE (qflux00)
+    IF (ALLOCATED  (ru_ns)) DEALLOCATE (ru_ns)
+    IF (ALLOCATED  (dr_ns)) DEALLOCATE (dr_ns)
+    IF (ALLOCATED  (tr_ns)) DEALLOCATE (tr_ns)
+    IF (ALLOCATED  (corr_veg_soil)) DEALLOCATE (corr_veg_soil)
+    IF (ALLOCATED  (corr_veg_soil_max)) DEALLOCATE (corr_veg_soil_max)
+    IF (ALLOCATED  (mc)) DEALLOCATE (mc)
+    IF (ALLOCATED  (soilmoist)) DEALLOCATE (soilmoist)
+    IF (ALLOCATED  (soil_wet)) DEALLOCATE (soil_wet)
+    IF (ALLOCATED  (soil_wet_litter)) DEALLOCATE (soil_wet_litter)
+    IF (ALLOCATED  (qflux)) DEALLOCATE (qflux)
+    IF (ALLOCATED  (tmat)) DEALLOCATE (tmat)
+    IF (ALLOCATED  (stmat)) DEALLOCATE (stmat)
+
+    RETURN 
+
+  END SUBROUTINE hydrol_clear
+
+  !! This routine initializes HYDROLOGIC variables
+  !! - mx_eau_var
+
+  SUBROUTINE hydrol_var_init (kjpindex, veget, soiltype, mx_eau_var, shumdiag, litterhumdiag, drysoil_frac, evap_bare_lim) 
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                          :: kjpindex      !! domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: veget         !! fraction of vegetation type
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in) :: soiltype      !! Map of soil types
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: mx_eau_var    !!
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out) :: shumdiag      !! relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: litterhumdiag !! litter humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: drysoil_frac  !! function of litter humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)       :: evap_bare_lim !! 
+    ! local declaration
+    REAL(r_std), DIMENSION (kjpindex)              :: dpu_mean  !! mean soil depth
+
+    INTEGER(i_std)                                     :: ji, jv, jd, jst, jsl
+    REAL(r_std)                                         :: m, frac
+    !
+    ! initialisation
+    mx_eau_var(:) = zero
+    dpu_mean(:)= zero
+    !
+    DO ji = 1,kjpindex
+       DO jst = 1,nstm
+          dpu_mean(ji)=dpu_mean(ji)+dpu(jst)*soiltype(ji,jst)
+       END DO
+    END DO
+    !
+    DO ji = 1,kjpindex
+       DO jst = 1,nstm
+          mx_eau_var(ji) = mx_eau_var(ji) + soiltype(ji,jst)*&
+               &   dpu(jst)*mille*mcs(jst)
+       END DO
+    END DO
+
+    DO ji = 1,kjpindex 
+       IF (vegtot(ji) .LE. zero) THEN
+          mx_eau_var(ji) = mx_eau_eau*deux
+       ENDIF
+
+    END DO
+
+
+    !
+    ! Calcul the matrix coef for dublin model:
+    ! pice-wise linearised hydraulic conductivity k_lin=alin * mc_lin + b_lin
+    ! and diffusivity d_lin in each interval of mc, called mc_lin,
+    ! between imin, for residual mcr, 
+    ! and imax for saturation mcs.
+    !
+    DO jst=1,nstm
+       m = un - un / nvan(jst)
+       !       WRITE(numout,*) 'jst',jst,imin,imax
+       mc_lin(imin,jst)=mcr(jst)
+       mc_lin(imax,jst)=mcs(jst)
+       tmcs(jst)=dpu(jst)* mille*mcs(jst)
+       zz(1,jst) = zero
+       dz(1,jst) = zero
+       DO jsl=2,nslm
+          zz(jsl,jst) = dpu(jst)* mille*((2**(jsl-1))-1)/ ((2**(nslm-1))-1)
+          dz(jsl,jst) = zz(jsl,jst)-zz(jsl-1,jst)
+          !          WRITE(numout,*) 'jsl, zz,dz',jsl, dpu(jst),zz(jsl,jst),dz(jsl,jst)
+       ENDDO
+       zz(nslm+1,jst) = zz(nslm,jst)
+       dz(nslm+1,jst) = zero
+       DO ji= imin+1, imax-1 
+          mc_lin(ji,jst) = mcr(jst) + (ji-imin)*(mcs(jst)-mcr(jst))/(imax-imin)
+       ENDDO
+       DO ji = imin,imax-1 
+          frac=MIN(un,(mc_lin(ji,jst)-mcr(jst))/(mcs(jst)-mcr(jst)))
+          k_lin(ji,jst) = ks(jst) * (frac**0.5) * ( un - ( un - frac ** (un/m)) ** m )**2
+          frac=MIN(un,(mc_lin(ji+1,jst)-mcr(jst))/(mcs(jst)-mcr(jst)))
+          k_lin(ji+1,jst) = ks(jst) * (frac**0.5) * ( un - ( un - frac ** (un/m)) ** m )**2
+          a_lin(ji,jst) = (k_lin(ji+1,jst)-k_lin(ji,jst)) / (mc_lin(ji+1,jst)-mc_lin(ji,jst))
+          b_lin(ji,jst)  = k_lin(ji,jst) - a_lin(ji,jst)*mc_lin(ji,jst)
+          !- Il faudrait ici definir a et b pour mc > mcs, et mc < mcr car c'est un cas auquel on peut etre confronte... a reflechir
+
+          IF(ji.NE.imin.AND.ji.NE.imax-1) THEN
+             frac=MIN(un,(mc_lin(ji,jst)-mcr(jst))/(mcs(jst)-mcr(jst)))
+             d_lin(ji,jst) =(k_lin(ji,jst) / (avan(jst)*m*nvan(jst))) *  &
+                  &  ( (frac**(-un/m))/(mc_lin(ji,jst)-mcr(jst)) ) * &
+                  &  (  frac**(-un/m) -un ) ** (-m)
+             frac=MIN(un,(mc_lin(ji+1,jst)-mcr(jst))/(mcs(jst)-mcr(jst)))
+             d_lin(ji+1,jst) =(k_lin(ji+1,jst) / (avan(jst)*m*nvan(jst)))*&
+                  &  ( (frac**(-un/m))/(mc_lin(ji+1,jst)-mcr(jst)) ) * &
+                  &  (  frac**(-un/m) -un ) ** (-m)
+             d_lin(ji,jst) = undemi * (d_lin(ji,jst)+d_lin(ji+1,jst))
+          ELSEIF(ji.EQ.imin) THEN
+             d_lin(ji,jst) = zero
+          ELSEIF(ji.EQ.imax-1) THEN
+             frac=MIN(un,(mc_lin(ji,jst)-mcr(jst))/(mcs(jst)-mcr(jst)))
+             d_lin(ji,jst) =(k_lin(ji,jst) / (avan(jst)*m*nvan(jst))) * &
+                  & ( (frac**(-un/m))/(mc_lin(ji,jst)-mcr(jst)) ) *  &
+                  & (  frac**(-un/m) -un ) ** (-m)
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+
+    ! Compute the litter humidity, shumdiag and fry
+
+    litterhumdiag(:) = zero
+    tmc_litt_mea(:) = zero
+    tmc_litt_wet_mea(:) = zero
+    tmc_litt_dry_mea(:) = zero
+    shumdiag(:,:) = zero
+    soilmoist(:,:) = zero
+    humtot(:) = zero
+    tmc(:,:) = zero
+
+    ! Loop on soil types to compute the variables (ji,jst)
+
+    DO jst=1,nstm 
+
+       ! the residual 1st layer soil moisture:
+       v1r(jst) = dz(2,jst)*mcr(jst)/deux
+
+       ! the saturated Bottom layer soil moisture: 
+       ! v A CALCULER SUR TOUT LE PROFIL (vs et vr egalement)
+       vBs(jst) = dz(nslm,jst)*mcs(jst)/deux
+       
+       ! The total soil moisture for each soil type:
+
+       DO ji=1,kjpindex
+          tmc(ji,jst)= dz(2,jst) * ( trois*mc(ji,1,jst)+ mc(ji,2,jst))/huit
+       END DO
+
+       DO jsl=2,nslm-1
+          DO ji=1,kjpindex
+             tmc(ji,jst) = tmc(ji,jst) + dz(jsl,jst) * ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
+          END DO
+       END DO
+
+       DO ji=1,kjpindex
+          tmc(ji,jst) = tmc(ji,jst) +  dz(nslm,jst) * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+       END DO
+
+
+       ! The litter variables:
+
+       DO ji=1,kjpindex
+          tmc_litter(ji,jst) = dz(2,jst) * (trois*mc(ji,1,jst)+mc(ji,2,jst))/huit
+          tmc_litter_wilt(ji,jst) = dz(2,jst) * mcw(jst) / deux
+          tmc_litter_res(ji,jst) = dz(2,jst) * mcr(jst) / deux
+          tmc_litter_field(ji,jst) = dz(2,jst) * mcf(jst) / deux
+          tmc_litter_sat(ji,jst) = dz(2,jst) * mcs(jst) / deux
+          tmc_litter_awet(ji,jst) = dz(2,jst) * mc_awet(jst) / deux
+          tmc_litter_adry(ji,jst) = dz(2,jst) * mc_adry(jst) / deux
+       END DO
+
+
+       ! sum from level 1 to 4
+
+       DO jsl=2,4
+
+          DO ji=1,kjpindex
+             tmc_litter(ji,jst) = tmc_litter(ji,jst) + dz(jsl,jst) * & 
+                  & ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
+
+             tmc_litter_wilt(ji,jst) = tmc_litter_wilt(ji,jst) + &
+                  &(dz(jsl,jst)+ dz(jsl+1,jst))*& 
+                  & mcw(jst)/deux
+             tmc_litter_res(ji,jst) = tmc_litter_res(ji,jst) + &
+                  &(dz(jsl,jst)+ dz(jsl+1,jst))*& 
+                  & mcr(jst)/deux
+             tmc_litter_sat(ji,jst) = tmc_litter_sat(ji,jst) + &
+                  &(dz(jsl,jst)+ dz(jsl+1,jst))* & 
+                  & mcs(jst)/deux
+             tmc_litter_field(ji,jst) = tmc_litter_field(ji,jst) + &
+                  & (dz(jsl,jst)+ dz(jsl+1,jst))* & 
+                  & mcf(jst)/deux
+             tmc_litter_awet(ji,jst) = tmc_litter_awet(ji,jst) + &
+                  &(dz(jsl,jst)+ dz(jsl+1,jst))* & 
+                  & mc_awet(jst)/deux
+             tmc_litter_adry(ji,jst) = tmc_litter_adry(ji,jst) + &
+                  & (dz(jsl,jst)+ dz(jsl+1,jst))* & 
+                  & mc_adry(jst)/deux
+          END DO
+
+       END DO
+
+
+       ! subsequent calcul of soil_wet_litter (tmc-tmcw)/(tmcf-tmcw)
+
+       DO ji=1,kjpindex
+          soil_wet_litter(ji,jst)=MIN(un, MAX(zero,&
+               &(tmc_litter(ji,jst)-tmc_litter_wilt(ji,jst))/&
+               & (tmc_litter_field(ji,jst)-tmc_litter_wilt(ji,jst)) ))
+       END DO
+
+       ! Soil wetness profiles (mc-mcw)/(mcs-mcw)
+
+       DO ji=1,kjpindex
+          soil_wet(ji,1,jst) = MIN(un, MAX(zero,&
+               &(trois*mc(ji,1,jst) + mc(ji,2,jst) - quatre*mcw(jst))&
+               & /(quatre*(mcs(jst)-mcw(jst))) ))
+          humrelv(ji,1,jst) = zero
+
+       END DO
+
+       DO jsl=2,nslm-1
+          DO ji=1,kjpindex
+             soil_wet(ji,jsl,jst) = MIN(un, MAX(zero,&
+                  & (trois*mc(ji,jsl,jst) + & 
+                  & mc(ji,jsl-1,jst) *(dz(jsl,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
+                  & + mc(ji,jsl+1,jst)*(dz(jsl+1,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
+                  & - quatre*mcw(jst)) / (quatre*(mcs(jst)-mcw(jst))) ))
+          END DO
+       END DO
+
+       DO ji=1,kjpindex
+          soil_wet(ji,nslm,jst) = MIN(un, MAX(zero,&
+               & (trois*mc(ji,nslm,jst) &
+               & + mc(ji,nslm-1,jst)-quatre*mcw(jst))/(quatre*(mcs(jst)-mcw(jst))) ))
+       END DO
+
+    END DO ! loop on soil type
+
+
+    !Now we compute the grid averaged values:
+
+    DO jst=1,nstm        
+       DO ji=1,kjpindex
+
+          humtot(ji) = humtot(ji) + soiltype(ji,jst) * tmc(ji,jst)
+
+          litterhumdiag(ji) = litterhumdiag(ji) + &
+               & soil_wet_litter(ji,jst) * soiltype(ji,jst)
+
+          tmc_litt_wet_mea(ji) =  tmc_litt_wet_mea(ji) + & 
+               & tmc_litter_awet(ji,jst)* soiltype(ji,jst)
+
+          tmc_litt_dry_mea(ji) = tmc_litt_dry_mea(ji) + &
+               & tmc_litter_adry(ji,jst) * soiltype(ji,jst) 
+
+          tmc_litt_mea(ji) = tmc_litt_mea(ji) + &
+               & tmc_litter(ji,jst) * soiltype(ji,jst) 
+       END DO
+
+
+
+       DO jsl=1,nbdl
+          DO ji=1,kjpindex
+             shumdiag(ji,jsl)= shumdiag(ji,jsl) + soil_wet(ji,jsl,jst) * &
+                  & ((mcs(jst)-mcw(jst))/(mcf(jst)-mcw(jst))) * &
+                  & soiltype(ji,jst)
+             soilmoist(ji,jsl) = soilmoist(ji,jsl) + mc(ji,jsl,jst)*soiltype(ji,jst)
+             shumdiag(ji,jsl) = MAX(MIN(shumdiag(ji,jsl), un), zero) 
+          END DO
+       END DO
+
+    END DO ! loop on soiltype
+    !
+    !
+    !
+    DO ji=1,kjpindex
+       drysoil_frac(ji) = un + MAX( MIN( (tmc_litt_dry_mea(ji) - tmc_litt_mea(ji)) / &
+            & (tmc_litt_wet_mea(ji) - tmc_litt_dry_mea(ji)), zero), - un)
+    END DO
+
+    evap_bare_lim = zero
+
+!!$    IF ( COUNT(diaglev .EQ. undef_sechiba) > 0 ) THEN
+!!$
+!!$       DO jsl=1,nbdl-1
+!!$          diaglev(jsl) = zz(jsl,1) + dz(jsl+1,1)/deux
+!!$       END DO
+!!$       diaglev(nbdl) = zz(nbdl,1)
+!!$       interpol_diag = .FALSE.
+!!$
+!!$    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' hydrol_var_init done '
+
+  END SUBROUTINE hydrol_var_init
+
+  !! This routine computes snow processes
+  !!
+  SUBROUTINE hydrol_snow (kjpindex, dtradia, precip_rain, precip_snow , temp_sol_new, soilcap,&
+       & frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
+       & tot_melt, snowdepth)
+
+    ! 
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia       !! Time step in seconds
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_rain   !! Rainfall
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_snow   !! Snow precipitation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: temp_sol_new  !! New soil temperature
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: soilcap       !! Soil capacity
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(in)     :: frac_nobio    !! Fraction of continental ice, lakes, ...
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: totfrac_nobio !! Total fraction of continental ice+lakes+ ...
+    ! modified fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu       !! Bare soil evaporation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapsno      !! Snow evaporation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: snow          !! Snow mass [Kg/m^2]
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: snow_age      !! Snow age
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout)  :: snow_nobio    !! Ice water balance
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout)  :: snow_nobio_age!! Snow age on ice, lakes, ...
+    ! output fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: tot_melt      !! Total melt  
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: snowdepth     !! Snow depth
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                               :: ji, jv
+    REAL(r_std), DIMENSION (kjpindex)             :: d_age  !! Snow age change
+    REAL(r_std), DIMENSION (kjpindex)             :: xx     !! temporary
+    REAL(r_std)                                   :: snowmelt_tmp !! The name says it all !
+
+    !
+    ! for continental points
+    !
+
+    !
+    ! 0. initialisation
+    !
+    DO jv = 1, nnobio
+       DO ji=1,kjpindex
+          subsnownobio(ji,jv) = zero
+       ENDDO
+    ENDDO
+    DO ji=1,kjpindex
+       subsnowveg(ji) = zero
+       snowmelt(ji) = zero
+       icemelt(ji) = zero
+       subsinksoil(ji) = zero
+       tot_melt(ji) = zero
+    ENDDO
+    !
+    ! 1. On vegetation
+    !
+    DO ji=1,kjpindex
+       !
+       ! 1.1. It is snowing
+       !
+       snow(ji) = snow(ji) + (un - totfrac_nobio(ji))*precip_snow(ji)
+       !
+       !
+       ! 1.2. Sublimation - separate between vegetated and no-veget fractions 
+       !      Care has to be taken as we might have sublimation from the
+       !      the frac_nobio while there is no snow on the rest of the grid.
+       !
+       IF ( snow(ji) > snowcri ) THEN
+          subsnownobio(ji,iice) = frac_nobio(ji,iice)*vevapsno(ji)
+          subsnowveg(ji) = vevapsno(ji) - subsnownobio(ji,iice)
+       ELSE
+          ! Correction Nathalie - Juillet 2006.
+          ! On doit d'abord tester s'il existe un frac_nobio!
+          ! Pour le moment je ne regarde que le iice
+          IF ( frac_nobio(ji,iice) .GT. min_sechiba) THEN
+             subsnownobio(ji,iice) = vevapsno(ji)
+             subsnowveg(ji) = zero
+          ELSE 
+             subsnownobio(ji,iice) = zero
+             subsnowveg(ji) = vevapsno(ji)
+          ENDIF
+       ENDIF
+       !
+       !
+       ! 1.2.1 Check that sublimation on the vegetated fraction is possible.
+       !
+       IF (subsnowveg(ji) .GT. snow(ji)) THEN
+          ! What could not be sublimated goes into soil evaporation
+          !         vevapnu(ji) = vevapnu(ji) + (subsnowveg(ji) - snow(ji))
+          IF( (un - totfrac_nobio(ji)).GT.min_sechiba) THEN
+             subsinksoil (ji) = (subsnowveg(ji) - snow(ji))/ (un - totfrac_nobio(ji))
+          END IF
+          ! Sublimation is thus limited to what is available
+          subsnowveg(ji) = snow(ji)
+          snow(ji) = zero
+          vevapsno(ji) = subsnowveg(ji) + subsnownobio(ji,iice)
+       ELSE
+          snow(ji) = snow(ji) - subsnowveg(ji)
+       ENDIF
+       !
+       ! 1.3. snow melt only if temperature positive
+       !
+       IF (temp_sol_new(ji).GT.tp_00) THEN
+          !
+          IF (snow(ji).GT.sneige) THEN
+             !
+             snowmelt(ji) = (un - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0
+             !
+             ! 1.3.1.1 enough snow for melting or not
+             !
+             IF (snowmelt(ji).LT.snow(ji)) THEN
+                snow(ji) = snow(ji) - snowmelt(ji)
+             ELSE
+                snowmelt(ji) = snow(ji)
+                snow(ji) = zero
+             END IF
+             !
+          ELSEIF (snow(ji).GE.zero) THEN
+             !
+             ! 1.3.2 not enough snow
+             !
+             snowmelt(ji) = snow(ji)
+             snow(ji) = zero
+          ELSE
+             !
+             ! 1.3.3 negative snow - now snow melt
+             !
+             snow(ji) = zero
+             snowmelt(ji) = zero
+             WRITE(numout,*) 'hydrol_snow: WARNING! snow was negative and was reset to zero. '
+             !
+          END IF
+
+       ENDIF
+       !
+       ! 1.4. Ice melt only if there is more than a given mass : maxmass_glacier,
+       !      i.e. only weight melts glaciers !
+       ! Ajouts Edouard Davin / Nathalie de Noblet add extra to melting
+       !
+       IF ( snow(ji) .GT. maxmass_glacier ) THEN
+          snowmelt(ji) = snowmelt(ji) + (snow(ji) - maxmass_glacier)
+          snow(ji) = maxmass_glacier
+       ENDIF
+       !
+    END DO
+    !
+    ! 2. On Land ice
+    !
+    DO ji=1,kjpindex
+       !
+       ! 2.1. It is snowing
+       !
+       snow_nobio(ji,iice) = snow_nobio(ji,iice) + frac_nobio(ji,iice)*precip_snow(ji) + &
+            & frac_nobio(ji,iice)*precip_rain(ji)
+       !
+       ! 2.2. Sublimation - was calculated before it can give us negative snow_nobio but that is OK
+       !      Once it goes below a certain values (-maxmass_glacier for instance) we should kill
+       !      the frac_nobio(ji,iice) !
+       !
+       snow_nobio(ji,iice) = snow_nobio(ji,iice) - subsnownobio(ji,iice)
+       !
+       ! 2.3. Snow melt only for continental ice fraction
+       !
+       snowmelt_tmp = zero
+       IF (temp_sol_new(ji) .GT. tp_00) THEN
+          !
+          ! 2.3.1 If there is snow on the ice-fraction it can melt
+          !
+          snowmelt_tmp = frac_nobio(ji,iice)*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0
+          !
+          IF ( snowmelt_tmp .GT. snow_nobio(ji,iice) ) THEN
+             snowmelt_tmp = MAX( zero, snow_nobio(ji,iice))
+          ENDIF
+          snowmelt(ji) = snowmelt(ji) + snowmelt_tmp
+          snow_nobio(ji,iice) = snow_nobio(ji,iice) - snowmelt_tmp
+          !
+       ENDIF
+       !
+       ! 2.4 Ice melt only if there is more than a given mass : maxmass_glacier, 
+       !     i.e. only weight melts glaciers !
+       !
+       IF ( snow_nobio(ji,iice) .GT. maxmass_glacier ) THEN
+          icemelt(ji) = snow_nobio(ji,iice) - maxmass_glacier
+          snow_nobio(ji,iice) = maxmass_glacier
+       ENDIF
+       !
+    END DO
+
+    !
+    ! 3. On other surface types - not done yet
+    !
+    IF ( nnobio .GT. 1 ) THEN
+       WRITE(numout,*) 'WE HAVE',nnobio-1,' SURFACE TYPES I DO NOT KNOW'
+       WRITE(numout,*) 'CANNOT TREAT SNOW ON THESE SURFACE TYPES'
+       STOP 'in hydrol_snow' 
+    ENDIF
+
+    !
+    ! 4. computes total melt (snow and ice)
+    !
+    DO ji = 1, kjpindex
+       tot_melt(ji) = icemelt(ji) + snowmelt(ji)
+    ENDDO
+
+    !
+    ! 5. computes snow age on veg and ice (for albedo)
+    !
+    DO ji = 1, kjpindex
+       !
+       ! 5.1 Snow age on vegetation
+       !
+       IF (snow(ji) .LE. zero) THEN
+          snow_age(ji) = zero
+       ELSE
+          snow_age(ji) =(snow_age(ji) + (un - snow_age(ji)/max_snow_age) * dtradia/one_day) &
+               & * EXP(-precip_snow(ji) / snow_trans)
+       ENDIF
+       !
+       ! 5.2 Snow age on ice
+       !
+       ! age of snow on ice: a little bit different because in cold regions, we really
+       ! cannot negect the effect of cold temperatures on snow metamorphism any more.
+       !
+       IF (snow_nobio(ji,iice) .LE. zero) THEN
+          snow_nobio_age(ji,iice) = zero
+       ELSE
+          !
+          d_age(ji) = ( snow_nobio_age(ji,iice) + &
+               &  (un - snow_nobio_age(ji,iice)/max_snow_age) * dtradia/one_day ) * &
+               &  EXP(-precip_snow(ji) / snow_trans) - snow_nobio_age(ji,iice)
+          IF (d_age(ji) .GT. min_sechiba ) THEN
+             xx(ji) = MAX( tp_00 - temp_sol_new(ji), zero )
+             xx(ji) = ( xx(ji) / 7._r_std ) ** 4._r_std
+             d_age(ji) = d_age(ji) / (un+xx(ji))
+          ENDIF
+          snow_nobio_age(ji,iice) = MAX( snow_nobio_age(ji,iice) + d_age(ji), zero )
+          !
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 6.0 Diagnose the depth of the snow layer
+    !
+
+    DO ji = 1, kjpindex
+       snowdepth(ji) = snow(ji) /sn_dens
+    ENDDO
+
+    IF (long_print) WRITE (numout,*) ' hydrol_snow done '
+
+  END SUBROUTINE hydrol_snow
+
+  !! This routine computes canopy processes
+  !!
+  SUBROUTINE hydrol_canop (kjpindex, precip_rain, vevapwet, veget, qsintmax, &
+       & qsintveg,precisol,tot_melt)
+
+    ! 
+    ! interface description
+    !
+    INTEGER(i_std), INTENT(in)                               :: kjpindex    !! Domain size
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_rain !! Rain precipitation
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: vevapwet    !! Interception loss
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: veget       !! Fraction of vegetation type 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: qsintmax    !! Maximum water on vegetation for interception
+    REAL(r_std), DIMENSION  (kjpindex), INTENT (in)          :: tot_melt         !! Total melt
+    ! modified fields
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: qsintveg    !! Water on vegetation due to interception
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)           :: precisol    !! Eau tombee sur le sol
+    ! output fields
+
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: zqsintvegnew
+    LOGICAL, SAVE                                  :: firstcall=.TRUE.
+    REAL(r_std), SAVE, DIMENSION(nvm)              :: throughfall_by_pft
+
+    IF ( firstcall ) THEN
+       !Config  Key  = PERCENT_THROUGHFALL_PFT
+       !Config  Desc = Percent by PFT of precip that is not intercepted by the canopy
+       !Config  Def  = 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30.
+       !Config  Help = During one rainfall event, PERCENT_THROUGHFALL_PFT% of the incident rainfall
+       !Config         will get directly to the ground without being intercepted, for each PFT.
+       
+       throughfall_by_pft = (/ 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30. /)
+       CALL getin_p('PERCENT_THROUGHFALL_PFT',throughfall_by_pft)
+       throughfall_by_pft = throughfall_by_pft / 100.
+
+       firstcall=.FALSE.
+    ENDIF
+
+
+    ! calcul de qsintmax a prevoir a chaque pas de temps
+    ! dans ini_sechiba
+    ! boucle sur les points continentaux
+    ! calcul de qsintveg au pas de temps suivant
+    ! par ajout du flux interception loss
+    ! calcule par enerbil en fonction
+    ! des calculs faits dans diffuco
+    ! calcul de ce qui tombe sur le sol
+    ! avec accumulation dans precisol
+    ! essayer d'harmoniser le traitement du sol nu
+    ! avec celui des differents types de vegetation
+    ! fait si on impose qsintmax ( ,1) = 0.0
+    !
+    ! loop for continental subdomain
+    !
+    !
+    ! 1. evaporation off the continents
+    !
+    ! 1.1 The interception loss is take off the canopy. 
+    DO jv=1,nvm
+       qsintveg(:,jv) = qsintveg(:,jv) - vevapwet(:,jv)
+    END DO
+
+    ! 1.2 It is raining : precip_rain is shared for each vegetation
+    ! type
+    !     sum (veget (1,nvm)) must be egal to 1-totfrac_nobio.
+    !     iniveget computes veget each day
+    !
+    DO jv=1,nvm
+       ! Correction Nathalie - Juin 2006 - une partie de la pluie arrivera toujours sur le sol
+       ! sorte de throughfall supplementaire
+       !qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * precip_rain(:)
+       qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * ((1-throughfall_by_pft(jv))*precip_rain(:))
+    END DO
+
+    !
+    ! 1.3 Limits the effect and sum what receives soil
+    !
+    precisol(:,:) = zero
+    DO jv=1,nvm
+       DO ji = 1, kjpindex
+          zqsintvegnew(ji,jv) = MIN (qsintveg(ji,jv),qsintmax(ji,jv)) 
+          ! correction throughfall Nathalie - Juin 2006
+          !precisol(ji,jv) = qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
+          precisol(ji,jv) = (veget(ji,jv)*throughfall_by_pft(jv)*precip_rain(ji)) + qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
+       ENDDO
+    END DO
+    !    
+    DO jv=1,nvm
+       DO ji = 1, kjpindex
+          IF (vegtot(ji).GT.min_sechiba) THEN
+             precisol(ji,jv) = precisol(ji,jv)+tot_melt(ji)*veget(ji,jv)/vegtot(ji)
+          ENDIF
+       ENDDO
+    END DO
+    !   
+    !
+    ! 1.4 swap qsintveg to the new value
+    !
+
+    DO jv=1,nvm
+       qsintveg(:,jv) = zqsintvegnew (:,jv)
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' hydrol_canop done '
+
+  END SUBROUTINE hydrol_canop
+  !!
+  !!
+  !!
+  SUBROUTINE hydrol_vegupd(kjpindex, veget, veget_max, soiltype,qsintveg,resdist)
+    !
+    !   The vegetation cover has changed and we need to adapt the reservoir distribution 
+    !   and the distribution of plants on different soil types.
+    !   You may note that this occurs after evaporation and so on have been computed. It is
+    !   not a problem as a new vegetation fraction will start with humrel=0 and thus will have no
+    !   evaporation. If this is not the case it should have been caught above.
+    !
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex 
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in)       :: veget            !! New vegetation map
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max        !! Max. fraction of vegetation type
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in)      :: soiltype         !! Map of soil types : proportion of each soil type
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)  :: qsintveg           !! Water on vegetation
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(inout)    :: resdist          !! Old vegetation map
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                :: ji,jv,jst,jst_pref
+    REAL(r_std), DIMENSION (kjpindex,nstm)         :: soil_exist,soil_exist_max
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: veget_exist,veget_exist_max
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: qsintveg2                   !! Water on vegetation due to interception over old veget
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: vmr                         !! variation of veget
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: qsdq
+    REAL(r_std), DIMENSION(kjpindex)               :: vegchtot,vtr, qstr, fra
+    REAL(r_std), PARAMETER                         :: EPS1 = EPSILON(un)
+    !
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+!mask
+!           vmr(ji,jv) = MAX ( EPSILON(un), MIN (  veget(ji,jv)-resdist(ji,jv) , MAX( EPSILON(un), veget(ji,jv)-resdist(ji,jv))  ) )
+                
+!            vmr(ji,jv) = MAX ( EPSILON(un),  MAX( EPSILON(un), veget(ji,jv)-resdist(ji,jv))  )
+!            IF(ABS(veget(ji,jv)-resdist(ji,jv)).gt.epsilon(un)) then
+!    WRITE(numout,*) '-----------------------------------------------'
+!    WRITE(numout,*) 'vmr,epsilon(un),veget,resdist',vmr(ji,jv),epsilon(un)
+!    WRITE(numout,*),veget(ji,jv),resdist(ji,jv)
+!    WRITE(numout,*) 'ABS(veget -resdist',ABS(veget(ji,jv)-resdist(ji,jv))
+!      endif
+          IF ( ABS(veget(ji,jv)-resdist(ji,jv)) .GT. EPS1 ) THEN
+             vmr(ji,jv) = veget(ji,jv)-resdist(ji,jv)
+          ELSE
+             vmr(ji,jv) = zero
+          ENDIF
+          !
+          IF (resdist(ji,jv) .GT. min_sechiba) THEN
+             qsintveg2(ji,jv) = qsintveg(ji,jv)/resdist(ji,jv)
+          ELSE
+             qsintveg2(ji,jv) = zero
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    vegchtot(:) = zero
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          vegchtot(ji) = vegchtot(ji) + ABS( vmr(ji,jv) )
+       ENDDO
+    ENDDO
+    !
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          IF ( vegchtot(ji) .GT. min_sechiba ) THEN
+             qsdq(ji,jv) = ABS(vmr(ji,jv)) * qsintveg2(ji,jv)
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! calculate water mass that we have to redistribute
+    !
+    qstr(:) = zero
+    vtr(:) = zero
+    !
+    !
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          IF ( ( vegchtot(ji) .GT. min_sechiba ) .AND. ( vmr(ji,jv) .LT. -min_sechiba ) ) THEN
+             qstr(ji) = qstr(ji) + qsdq(ji,jv)
+             vtr(ji) = vtr(ji) - vmr(ji,jv)
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! put it into reservoir of plant whose surface area has grown
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          IF ( vegchtot(ji) .GT. min_sechiba .AND. ABS(vtr(ji)) .GT. EPSILON(un)) THEN
+             fra(ji) = vmr(ji,jv) / vtr(ji)
+             IF ( vmr(ji,jv) .GT. min_sechiba)  THEN
+                qsintveg(ji,jv) = qsintveg(ji,jv) + fra(ji)* qstr(ji)
+             ELSE
+                qsintveg(ji,jv) = qsintveg(ji,jv) - qsdq(ji,jv)
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+!MM underflow :
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+         IF ( ABS(qsintveg(ji,jv)) > zero .AND. ABS(qsintveg(ji,jv)) < EPS1 ) THEN
+            qsintveg(ji,jv) = EPS1
+         ENDIF
+      ENDDO
+   ENDDO
+
+    !   Now that the work is done resdist needs an update !
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          resdist(ji,jv) = veget(ji,jv)
+       ENDDO
+    ENDDO
+
+
+    ! Distribution of the vegetation depending on the soil type
+
+!    DO jst = 1, nstm
+!
+!       DO ji = 1, kjpindex
+!
+!           
+!          soil_exist(ji,jst)=zero
+!          IF (soiltype(ji,jst) .NE. zero) THEN
+!             soil_exist(ji,jst)=un
+!             soil_exist_max(ji,jst)=un
+!          ENDIF
+!
+!       ENDDO
+!
+!    ENDDO
+
+    soil_exist(:,:) = mask_soiltype(:,:)
+    soil_exist_max(:,:) = mask_soiltype(:,:)
+    veget_exist(:,:) = zero
+    veget_exist_max(:,:) = zero
+
+    DO jv = 1, nvm
+
+       DO ji = 1, kjpindex
+          IF(vegtot(ji).GT.min_sechiba) THEN
+             veget_exist(ji,jv)= veget(ji,jv)/vegtot(ji)
+             veget_exist_max(ji,jv)= veget_max(ji,jv)/vegtot(ji)
+          ENDIF
+       ENDDO
+    ENDDO
+
+    ! Compute corr_veg_soil 
+
+    corr_veg_soil(:,:,:) = zero
+    corr_veg_soil_max(:,:,:) = zero
+
+    IF ( COUNT(pref_soil_veg .EQ. 0) > 0 ) THEN
+
+       DO jst = 1, nstm
+
+          DO jv = nvm, 1, -1
+
+             DO ji=1,kjpindex
+
+                IF(vegtot(ji).GT.min_sechiba.AND.soiltype(ji,jst).GT.min_sechiba) THEN
+                   corr_veg_soil(ji,jv,jst) = veget(ji,jv)/vegtot(ji)
+                   corr_veg_soil_max(ji,jv,jst) = veget_max(ji,jv)/vegtot(ji)
+                END IF
+
+             END DO
+          END DO
+       END DO
+
+    ELSE
+
+
+       DO jst = 1, nstm
+
+          DO jv = nvm, 1, -1
+
+             jst_pref = pref_soil_veg(jv,jst)
+
+             DO ji=1,kjpindex
+                corr_veg_soil(ji,jv,jst_pref) = zero
+                corr_veg_soil_max(ji,jv,jst_pref) = zero
+                !for veget distribution used in sechiba via humrel
+                IF (soil_exist(ji,jst_pref).GT.min_sechiba) THEN
+                   corr_veg_soil(ji,jv,jst_pref)=MIN(veget_exist(ji,jv)/soiltype(ji,jst_pref),soil_exist(ji,jst_pref))
+                   veget_exist(ji,jv)=MAX(veget_exist(ji,jv)-soil_exist(ji,jst_pref)*soiltype(ji,jst_pref),zero)
+                   soil_exist(ji,jst_pref)=MAX(soil_exist(ji,jst_pref)-corr_veg_soil(ji,jv,jst_pref),zero)
+                ENDIF
+                !same for max veget_max used in stomate via vegstress for slowproc
+                IF (soil_exist_max(ji,jst_pref).GT.min_sechiba) THEN
+                   corr_veg_soil_max(ji,jv,jst_pref)= &
+               &     MIN(veget_exist_max(ji,jv)/soiltype(ji,jst_pref),soil_exist_max(ji,jst_pref))
+                   veget_exist_max(ji,jv)=MAX(veget_exist_max(ji,jv)-soil_exist_max(ji,jst_pref)*soiltype(ji,jst_pref),zero)
+                   soil_exist_max(ji,jst_pref)=MAX(soil_exist_max(ji,jst_pref)-corr_veg_soil_max(ji,jv,jst_pref),zero)
+                ENDIF 
+             ENDDO
+
+          ENDDO
+
+       ENDDO
+      ENDIF
+      !
+      ! update the corresponding masks
+      !
+!       mask_veget(:,:) = MIN( un, MAX(zero,veget(:,:)))
+!       mask_corr_veg_soil(:,:,:) = MIN( un, MAX(zero,corr_veg_soil(:,:,:)))
+
+       mask_veget(:,:) = 0
+       mask_corr_veg_soil(:,:,:) = 0
+
+       DO ji = 1, kjpindex
+
+          DO jv = 1, nvm
+             IF(veget(ji,jv) .GT. min_sechiba) THEN
+                mask_veget(ji,jv) = 1
+             ENDIF
+          
+             DO jst = 1, nstm
+                IF(corr_veg_soil(ji,jv,jst) .GT. min_sechiba) THEN
+                   mask_corr_veg_soil(ji,jv,jst) = 1
+                ENDIF
+             END DO
+          END DO
+          
+!      WRITE(numout,*) 'mask: soiltype,mask_soiltype',soiltype(ji,:),mask_soiltype(ji,:)
+
+       END DO
+      !
+
+    RETURN
+    !
+  END SUBROUTINE hydrol_vegupd
+  !!
+  !! this routine computes soil processes with CWRR scheme
+  !!
+  SUBROUTINE hydrol_soil (kjpindex, dtradia, veget, veget_max, soiltype, transpir, vevapnu, evapot, &
+       & evapot_penm, runoff, drainage, returnflow, irrigation, &
+       & tot_melt, evap_bare_lim,  shumdiag, litterhumdiag, humrel,vegstress, drysoil_frac)
+    ! 
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex 
+    ! input fields
+    REAL(r_std), INTENT (in)                                 :: dtradia          !! Time step in seconds
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)       :: veget            !! Map of vegetation types
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)       :: veget_max        !! Map of max vegetation types
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in)      :: soiltype         !! Map of soil types
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: transpir         !! transpiration
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu          !! 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: returnflow       !! Water returning to the deep reservoir
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: irrigation       !! Irrigation 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: evapot           !! 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: evapot_penm      !! 
+    ! modified fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: runoff           !! complete runoff
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: drainage         !! complete drainage
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: tot_melt
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: evap_bare_lim    !!
+    REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (out)     :: shumdiag         !! relative soil moisture
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: litterhumdiag    !! litter humidity
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (inout)    :: humrel           !! Relative humidity
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out)      :: vegstress        !! Veg. moisture stress (only for vegetation growth)
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: drysoil_frac     !! Function of the litter humidity, that will be used to compute albedo
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                :: ji, jv, jsl, jsl1, jst, ji_nsat  !! indices
+    INTEGER(i_std)                                :: m_sl0, m_sl1, isat !! mask values
+    REAL(r_std)                                    :: dztmp                       !! temporary depth
+    REAL(r_std)                                    :: temp                        !! temporary value for fluxes
+    REAL(r_std)                                    :: dpue                        !! temporary depth
+    REAL(r_std), DIMENSION(kjpindex)               :: tmcold, tmcint
+    REAL(r_std), DIMENSION(kjpindex,nslm,nstm)     :: moderwilt
+    REAL(r_std), DIMENSION(kjpindex,nslm)          :: mcint                      !! To save mc values for future use
+    REAL(r_std), DIMENSION(kjpindex)               :: correct_excess             !! Corrects the flux at nslme layer in case of under residual moisture 
+    REAL(r_std), DIMENSION(kjpindex)               :: mce                        !! Same use as mcint but jut for last efficient layer nslme 
+    REAL(r_std), DIMENSION(kjpindex)               :: under_mcr                  !! Allows under residual soil moisture due to evap 
+    REAL(r_std), DIMENSION(kjpindex,nstm)          :: v2
+    REAL(r_std), DIMENSION(kjpindex,nstm)          :: evap_bare_lim_ns           !! limitation of bare soi evaporation on each soil column (used to deconvoluate vevapnu)
+    REAL(r_std)                                    :: deltahum,diff
+    REAL(r_std), DIMENSION(kjpindex)               :: tsink
+    REAL(r_std), DIMENSION(kjpindex)               :: returnflow_soil
+    REAL(r_std), DIMENSION(kjpindex)               :: irrigation_soil
+    REAL(r_std), DIMENSION(kjpindex,nstm)          :: runoff_excess              !! Runoff generated after soil saturation
+    REAL(r_std)                                    :: excess
+    LOGICAL                                       :: propagate                  !! if we propagate an excess
+    !
+    !
+    returnflow_soil(:) = zero
+    irrigation_soil(:) = zero
+    qflux(:,:,:) = zero
+    mask_return(:) = 0
+    index_nsat(:,:) = 0
+    index_sat(:,:) = 0
+    nslme(:,:) = nslm
+    runoff_excess(:,:) = zero
+    mce(:) = zero
+    under_mcr(:) = zero
+    correct_excess(:) = zero
+    free_drain_coef(:,:) = zero
+    n_sat(:) = 0
+    n_nsat(:) = 1
+    !
+    ! split 2d variables to 3d variables, per soil type
+    !
+        CALL hydrol_split_soil (kjpindex, veget, soiltype, vevapnu, transpir, humrel, evap_bare_lim)
+    !
+    ! for each soil type
+    !
+    DO ji=1,kjpindex
+       IF(vegtot(ji).GT.min_sechiba) THEN
+          returnflow_soil(ji) = returnflow(ji)/vegtot(ji)
+          irrigation_soil(ji) = irrigation(ji)/vegtot(ji)
+       ENDIF
+
+       DO jst=1, nstm
+          !- A priori on considere qu'on est non sature si soiltype > 0
+          index_nsat(n_nsat(jst),jst)= ji*mask_soiltype(ji,jst)
+          n_nsat(jst)=n_nsat(jst)+mask_soiltype(ji,jst)
+       ENDDO
+       
+       IF(returnflow_soil(ji).GT.min_sechiba) THEN 
+          mask_return(ji) = 1
+          DO jst= 1,nstm
+             isat=1
+             nslme(ji,jst)=nslm-isat
+             !
+             DO jsl= nslm,3,-1
+                IF(mcs(jst)-mc(ji,jsl,jst).LT.min_sechiba) THEN 
+                   nslme(ji,jst) = nslme(ji,jst) - isat
+                ELSE
+                   isat = 0
+                ENDIF
+             ENDDO
+             ! We compute the indeces of the non-saturated points
+             IF (nslme(ji,jst).LT.2) THEN
+                nslme(ji,jst) = 0
+                ! En fait on est sature!
+                n_nsat(jst)=n_nsat(jst)-1
+                n_sat(jst) = n_sat(jst)+1
+                index_sat(n_sat(jst),jst)=ji
+             ENDIF
+          ENDDO
+       ENDIF
+    ENDDO
+
+    DO jst = 1,nstm
+       n_nsat(jst) = n_nsat(jst)-1
+    ENDDO
+
+    DO jst = 1,nstm
+       !
+       !- We compute the sum of the sinks for future check-up
+       DO ji=1,kjpindex
+          tsink(ji) = SUM(rootsink(ji,:,jst))+MAX(ae_ns(ji,jst),zero)+subsinksoil(ji)
+       ENDDO
+
+       ! We save the Total moisture content
+       tmcold(:) = tmc(:,jst)
+
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+
+          !- the bare soil evaporation is substracted to the soil moisture profile:  
+
+          dpue = zz(nslme(ji,jst),jst) + dz(nslme(ji,jst)+1,jst) / deux
+          DO jsl = 1, nslme(ji,jst)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) &
+                  & - (MAX(ae_ns(ji,jst),zero) + subsinksoil(ji)) / dpue
+          ENDDO
+
+          !- we add the returnflow to the last efficient layer in the soil
+          mc(ji,nslme(ji,jst),jst) = mc(ji,nslme(ji,jst),jst) + deux * returnflow_soil(ji) &
+               & / (dz(nslme(ji,jst),jst) + dz(nslme(ji,jst)+1,jst))
+
+       ENDDO
+
+!!! SUBROUTINE hydrol_avoid_underres
+       !-when mc(ji,1,jst)<mcr, we put it to mcr:
+       ! Smooth the profile to avoid negative values of ponctual soil moisture:
+
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+          !
+          ! Shifts water lack from top to bottom for under-residual moisture cases
+          DO jsl = 1,nslm-1
+             excess = MAX(mcr(jst)-mc(ji,jsl,jst),zero)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) + excess
+             mc(ji,jsl+1,jst) = mc(ji,jsl+1,jst) - excess * &
+                  &  (dz(jsl,jst)+dz(jsl+1,jst))/(dz(jsl+1,jst)+dz(jsl+2,jst))
+          ENDDO
+          
+          excess = MAX(mcr(jst)-mc(ji,nslm,jst),zero)
+          mc(ji,nslm,jst) = mc(ji,nslm,jst) + excess
+          
+          !- Then if the soil moisture at bottom is not sufficient, we try to refill the column from the top
+          DO jsl = nslm-1,1,-1
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) - excess * &
+                  &  (dz(jsl+1,jst)+dz(jsl+2,jst))/(dz(jsl+1,jst)+dz(jsl,jst))
+             excess = MAX(mcr(jst)-mc(ji,jsl,jst),zero)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) + excess
+          ENDDO
+          
+          excess = excess * mask_soiltype(ji,jst)
+          mc(ji,:,jst) = mc(ji,:,jst) * mask_soiltype(ji,jst)
+          
+          ! Keep the value in case excess is still positive (due to big change in evapot)
+          under_mcr(ji) = excess * dz(2,jst)/2
+       END DO
+!!! END SUBROUTINE hydrol_avoid_underres
+
+       !-we keep the value of mc in mcint:
+
+       DO jsl = 1, nslm
+          DO ji = 1, kjpindex
+             mcint(ji,jsl) = mc(ji,jsl,jst) - under_mcr(ji) / (dpu(jst) * mille)
+          ENDDO
+       ENDDO
+
+       DO ji = 1, kjpindex
+          tmcint(ji) = dz(2,jst) * ( trois*mcint(ji,1) + mcint(ji,2) )/huit 
+       ENDDO
+
+       DO jsl = 2,nslm-1
+          DO ji = 1, kjpindex
+             tmcint(ji) = tmcint(ji) + dz(jsl,jst) &
+                  & * (trois*mcint(ji,jsl)+mcint(ji,jsl-1))/huit &
+                  & + dz(jsl+1,jst) * (trois*mcint(ji,jsl)+mcint(ji,jsl+1))/huit
+          ENDDO
+       END DO
+       !
+       DO ji = 1, kjpindex
+          tmcint(ji) = tmcint(ji) + dz(nslm,jst) &
+               & * (trois * mcint(ji,nslm) + mcint(ji,nslm-1))/huit
+       ENDDO
+       
+       !- On retire les termes puits de la transpiration des couches inactives a la premiere couche inactive.
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+
+          DO jsl = nslme(ji,jst)+1,nslm                   ! Allows to use mc(ji,nslme(ji,jst)+1,jst)
+             mc(ji,nslme(ji,jst)+1,jst) = mc(ji,nslme(ji,jst)+1,jst) & 
+                  & - deux * rootsink(ji,jsl,jst) / & 
+                  & (dz(nslme(ji,jst)+1,jst) + dz(nslme(ji,jst)+2,jst))       
+             !- ATTENTION: n'est pas traite le cas ou la premiere couche inactive ne peut satisfaire la demande en eau des racines en dessous:
+             !- Le cas ne devrait pas se poser a priori
+             
+          ENDDO
+       ENDDO
+
+       !- Some initialisation necessary for the diffusion scheme to work
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+          !
+          ! 
+          !
+          !- We correct rootsink for first two layers so that it is not too low in the first layer
+          v1(ji,jst) = dz(2,jst)/huit * (trois * mc(ji,1,jst)+ mc(ji,2,jst))
+          rootsink(ji,2,jst) = rootsink(ji,2,jst) + MAX(rootsink(ji,1,jst)-v1(ji,jst), zero) 
+          rootsink(ji,1,jst) = MIN(rootsink(ji,1,jst),v1(ji,jst))
+          !- estimate maximum surface flux in mm/step, assuming 
+          !- all available water
+          flux(ji) = zero
+
+          IF(vegtot(ji).GT.min_sechiba) THEN
+             flux(ji) = precisol_ns(ji,jst) - evapot_penm(ji)*&
+                  & AINT(corr_veg_soil(ji,1,jst)+un-min_sechiba) &
+                  & + irrigation_soil(ji)            
+          ENDIF
+          !- The incoming flux is first dedicated to fill the soil up to mcr (in case needed)
+          temp = MAX(MIN(flux(ji),under_mcr(ji)), zero)
+          flux(ji) = flux(ji) - temp
+          under_mcr(ji) = under_mcr(ji) - temp
+       END DO
+
+       !- module to implement dublin model for one time-step
+       !-	gravity drainage as lower boundary layer
+       !- m.bruen, CWRR, ucd. 
+       !
+       !-step3: matrix resolution
+       !-calcul of the matrix coefficients
+
+       !- coefficient are computed depending on the profile mcint:
+
+       CALL hydrol_soil_setup(kjpindex,jst,dtradia)
+
+       !- Set the values for diffusion scheme
+
+
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+
+          ! We only run the scheme in case we are not under mcr with the incoming flux
+          IF (under_mcr(ji).LT.min_sechiba) THEN
+             resolv(ji)=.TRUE.
+             ! In under residual case, we equally spread the transpiration over the layers
+          ELSE
+             under_mcr(ji) = under_mcr(ji) + SUM(rootsink(ji,:,jst))
+          ENDIF
+          !-        First layer
+
+          tmat(ji,1,1) = zero
+          tmat(ji,1,2) = f(ji,1)
+          tmat(ji,1,3) = g1(ji,1)
+          rhs(ji,1)    = fp(ji,1) * mc(ji,1,jst) + gp(ji,1)*mc(ji,2,jst) &
+               &  + flux(ji) - (b(ji,1) + b(ji,2))*(dtradia/one_day)/deux - rootsink(ji,1,jst)
+
+          !-	soil body
+          DO jsl=2, nslme(ji,jst)-1
+             tmat(ji,jsl,1) = e(ji,jsl)
+             tmat(ji,jsl,2) = f(ji,jsl)
+             tmat(ji,jsl,3) = g1(ji,jsl)
+             rhs(ji,jsl) = ep(ji,jsl)*mc(ji,jsl-1,jst) + fp(ji,jsl)*mc(ji,jsl,jst) &
+                  & +  gp(ji,jsl) * mc(ji,jsl+1,jst) & 
+                  & + (b(ji,jsl-1) - b(ji,jsl+1)) * (dtradia/one_day) / deux & 
+                  & - rootsink(ji,jsl,jst) 
+          ENDDO
+       
+          !-        Last layer
+          jsl=nslme(ji,jst)
+          tmat(ji,jsl,1) = e(ji,jsl)
+          tmat(ji,jsl,2) = f(ji,jsl)
+          tmat(ji,jsl,3) = zero
+          rhs(ji,jsl) = ep(ji,jsl)*mc(ji,jsl-1,jst) + fp(ji,jsl)*mc(ji,jsl,jst) &
+               & + (b(ji,jsl-1) - b(ji,jsl)) * (dtradia/one_day) / deux & 
+               & - rootsink(ji,jsl,jst)
+
+          !- store the equations in case needed again
+          DO jsl=1,nslm
+             srhs(ji,jsl) = rhs(ji,jsl)
+             stmat(ji,jsl,1) = tmat(ji,jsl,1)
+             stmat(ji,jsl,2) = tmat(ji,jsl,2)
+             stmat(ji,jsl,3) = tmat(ji,jsl,3) 
+          ENDDO
+       ENDDO
+
+       !
+       !- step 4 : solve equations assuming atmosphere limiting
+       !-
+
+       CALL hydrol_soil_tridiag(kjpindex,jst)
+
+
+       !	
+       !- step 5 : check if really atmosphere limiting
+       !-
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+
+          resolv(ji) = .FALSE.
+          !
+          !- Prepare to rerun in case of under residual with evaporation or over saturation
+          !-
+          IF(mc(ji,1,jst).LT.(mcr(jst)-min_sechiba).AND.evapot_penm(ji).GT.min_sechiba) THEN
+
+             !- upper layer dry
+             !- We only rerun the scheme in case it is possible to reduce the evaporation
+             resolv(ji) = .TRUE.
+             DO jsl=1,nslm
+                rhs(ji,jsl) = srhs(ji,jsl)
+                tmat(ji,jsl,1) = stmat(ji,jsl,1)
+                tmat(ji,jsl,2) = stmat(ji,jsl,2)
+                tmat(ji,jsl,3) = stmat(ji,jsl,3)
+             END DO
+             tmat(ji,1,2) = un
+             tmat(ji,1,3) = zero
+             rhs(ji,1) = mcr(jst)-dmcr    
+             
+          ELSE
+             IF(mc(ji,1,jst).GT.(mcs(jst)+0.02)) THEN
+                
+                !- upper layer saturated
+                resolv(ji) = .TRUE.
+                DO jsl=1,nslm
+                   rhs(ji,jsl) = srhs(ji,jsl)
+                   tmat(ji,jsl,1) = stmat(ji,jsl,1)
+                   tmat(ji,jsl,2) = stmat(ji,jsl,2)
+                   tmat(ji,jsl,3) = stmat(ji,jsl,3)
+                END DO
+                tmat(ji,1,2) = un
+                tmat(ji,1,3) = zero
+                rhs(ji,1) = mcs(jst)+dmcs                
+
+             ENDIF
+          ENDIF
+       ENDDO
+
+       !
+       !- step 6 : resolve the equations with new boundary conditions if necessary
+       !-
+
+       CALL hydrol_soil_tridiag(kjpindex,jst)
+
+       !-
+       !- step 6.5 : initialize qflux at bottom of diffusion and avoid over saturated or under residual soil moisture 
+       !-
+
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+
+          m_sl0 = mask_return(ji)                  ! the last efficient layer is above the last layer (nslm)
+          
+          !- We add the flux from the last active layer to the first inactive one (not taken into account in the diffusion)
+          !- At the same time, we initialize qflux(ji,jsl,jst) which is useful in case of no returnflow.
+          !- When the first inactive point is to be saturated by the flux, the last efficient begins to fill up and the flux is changed
+          jsl=nslme(ji,jst)
+          qflux(ji,jsl,jst) = (a(ji,jsl)*(w_time*mc(ji,jsl,jst) &
+               &  + (un-w_time)*mcint(ji,jsl)) + b(ji,jsl)) * (dtradia/one_day)
+          
+          mc(ji,jsl+m_sl0,jst) = mc(ji,jsl+m_sl0,jst) + &
+               & m_sl0 * deux * qflux(ji,jsl,jst) / (dz(jsl+m_sl0,jst) + dz(jsl+m_sl0+1,jst))
+          
+          excess = m_sl0 * MAX(mc(ji,jsl+m_sl0,jst)-mcs(jst),zero)
+          mc(ji,jsl+m_sl0,jst) = mc(ji,jsl+m_sl0,jst) - excess
+          
+          DO jsl1 = jsl*m_sl0,1,-1 
+             mc(ji,jsl1,jst) = mc(ji,jsl1,jst) + excess * &
+                  & (dz(jsl1+1,jst) + dz(jsl1+2,jst))/(dz(jsl1,jst) + dz(jsl1+1,jst))
+             excess = MAX(mc(ji,jsl1,jst) - mcs(jst),zero)
+             mc(ji,jsl1,jst) = mc(ji,jsl1,jst) - excess
+          ENDDO
+          
+          ! Smooth the profile to avoid negative values of ponctual soil moisture
+          DO jsl = 1,nslm-1
+             excess = MAX(mcr(jst)-mc(ji,jsl,jst),zero)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) + excess
+             mc(ji,jsl+1,jst) = mc(ji,jsl+1,jst) - excess * &
+                  &  (dz(jsl,jst)+dz(jsl+1,jst))/(dz(jsl+1,jst)+dz(jsl+2,jst))
+          ENDDO
+          
+          excess = MAX(mcr(jst)-mc(ji,nslm,jst),zero)
+          mc(ji,nslm,jst) = mc(ji,nslm,jst) + excess
+          
+          !- Then if the soil moisture at bottom is not sufficient, we try to refill the column from the top
+          DO jsl = nslm-1,1,-1
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) - excess * &
+                  &  (dz(jsl+1,jst)+dz(jsl+2,jst))/(dz(jsl+1,jst)+dz(jsl,jst))
+             excess = MAX(mcr(jst)-mc(ji,jsl,jst),zero)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) + excess
+          ENDDO
+          
+          excess = excess * mask_soiltype(ji,jst)
+          mc(ji,:,jst) = mc(ji,:,jst) * mask_soiltype(ji,jst)
+          
+          ! Keep the value in case excess is still positive (due to big change in evapot)
+          under_mcr(ji) = under_mcr(ji) + excess * dz(2,jst)/2                
+          
+          !- We do the opposite thing: in case of over-saturation we put the water where it is possible
+          DO jsl = 1, nslm-1
+             excess = MAX(mc(ji,jsl,jst)-mcs(jst),zero)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) - excess
+             mc(ji,jsl+1,jst) = mc(ji,jsl+1,jst) + excess * &
+                  &  (dz(jsl,jst)+dz(jsl+1,jst))/(dz(jsl+1,jst)+dz(jsl+2,jst))
+          ENDDO
+ 
+          DO jsl = nslm,2,-1
+             excess = MAX(mc(ji,jsl,jst)-mcs(jst),zero)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) - excess
+             mc(ji,jsl-1,jst) = mc(ji,jsl-1,jst) + excess * &
+                  &  (dz(jsl,jst)+dz(jsl+1,jst))/(dz(jsl-1,jst)+dz(jsl,jst))
+          ENDDO
+          excess = MAX(mc(ji,1,jst)-mcs(jst),zero)
+          mc(ji,1,jst) = mc(ji,1,jst) - excess
+          
+       ENDDO  ! loop on grid
+
+       ! Finaly, for soil that are under-residual, we just equally distribute the lack of water
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+          DO jsl = 1, nslm
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) - under_mcr(ji) / (dpu(jst) * mille)
+          ENDDO
+       ENDDO
+
+       IF (check_cwrr) THEN
+          DO ji_nsat=1,n_nsat(jst)
+             ji = index_nsat(ji_nsat,jst)
+             IF(qflux(ji,nslm,jst)+returnflow_soil(ji).LT.-min_sechiba.AND.soiltype(ji,jst).GT.min_sechiba) THEN
+                WRITE(numout,*)'NEGATIVE FLUX AT LAST EFFICIENT LAYER IN SOIL'
+                WRITE(numout,*)'mc[nlsm]_(t), mc[nslm]_(t-1),jst,soil,ji',&
+                     & mc(ji,nslm,jst),mcint(ji,nslm),jst,soiltype(ji,jst),ji
+                WRITE(numout,*)'irrigation,returnflow,fdc',irrigation_soil(ji),returnflow_soil(ji)
+             ENDIF
+          END DO
+       ENDIF
+       !
+       !- step 7 : close the water balance
+       !
+       !- drainage through the lower boundary
+       !- and fluxes for each soil layer
+       !- with mass balance computed from the bottom to the top 
+       !- of the soil column
+
+       !- Compute the flux at every level from bottom to top (using mc and sink values)
+
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+          m_sl0 = mask_return(ji)                  ! the last efficient layer is above the last layer
+
+          DO jsl=nslm-1,nslme(ji,jst),-1
+             qflux(ji,jsl,jst) = qflux(ji,jsl+1,jst) & 
+                  &  + (mc(ji,jsl+1,jst) - mcint(ji,jsl+1)) &
+                  &  * (dz(jsl+1,jst)+dz(jsl+2,jst))/deux &
+                  &  + rootsink(ji,jsl+1,jst) 
+          ENDDO
+
+          jsl = nslme(ji,jst)-1
+          qflux(ji,jsl,jst) = qflux(ji,jsl+1,jst) & 
+               &  + (mc(ji,jsl,jst)-mcint(ji,jsl) &
+               &  + trois*mc(ji,jsl+1,jst) - trois*mcint(ji,jsl+1)) &
+               &  * (dz(jsl+1,jst)/huit) &
+               &  + rootsink(ji,jsl+1,jst) &
+               &  + (dz(jsl+2,jst)/deux) &                    ! zero if nslme=nslm
+               &  * (mc(ji,jsl+1,jst) - mcint(ji,jsl+1))
+
+          DO jsl = nslme(ji,jst)-2,1,-1
+             qflux(ji,jsl,jst) = qflux(ji,jsl+1,jst) & 
+                  &  + (mc(ji,jsl,jst)-mcint(ji,jsl) &
+                  &  + trois*mc(ji,jsl+1,jst) - trois*mcint(ji,jsl+1)) &
+                  &  * (dz(jsl+1,jst)/huit) &
+                  &  + rootsink(ji,jsl+1,jst) &
+                  &  + (dz(jsl+2,jst)/huit) &
+                  &  * (trois*mc(ji,jsl+1,jst) - trois*mcint(ji,jsl+1) &
+                  &  + mc(ji,jsl+2,jst)-mcint(ji,jsl+2)) 
+          END DO
+
+          qflux00(ji,jst) =  qflux(ji,1,jst) + (dz(2,jst)/huit) &
+               &  * (trois* (mc(ji,1,jst)-mcint(ji,1)) + (mc(ji,2,jst)-mcint(ji,2))) &
+               &  + rootsink(ji,1,jst)
+       ENDDO
+
+       !- Then computes the water balance (evap-runoff-drainage)
+
+       DO ji_nsat=1,n_nsat(jst)
+          ji = index_nsat(ji_nsat,jst)
+          !
+          !
+          ! deduction of ae_ns and ru_ns:
+          ! ae_ns+ru_ns=precisol_ns+irrigation-q0  
+          !
+          ae_ns(ji,jst) = MAX(MIN((precisol_ns(ji,jst)+irrigation_soil(ji)-qflux00(ji,jst)),evapot_penm(ji)),zero)
+          ru_ns(ji,jst) = precisol_ns(ji,jst)+irrigation_soil(ji)-qflux00(ji,jst)-ae_ns(ji,jst) !+runoff_excess(ji,jst)
+          !
+          ! In case of negative runoff, we correct it by taking water from the soil
+          ! Le probleme est que desormais, les qflux ne sont plus justes...
+          ! A corriger plus tard...
+          IF (ru_ns(ji,jst).LT.-min_sechiba) THEN
+             WRITE(numout,*) 'Negative runoff corrected', ru_ns(ji,jst), mc(ji,1,jst), SUM(rootsink(ji,:,jst))
+             WRITE(numout,*) 'At...', ji, jst, mask_soiltype(ji,jst), nslme(ji,jst) 
+             excess = -ru_ns(ji,jst)
+             ru_ns(ji,jst) = zero
+             ! We correct this by taking water from the whole soil
+             qflux00(ji,jst) = qflux00(ji,jst) - excess
+             dpue = zz(nslme(ji,jst),jst) + dz(nslme(ji,jst)+1,jst) / deux
+             DO jsl = 1, nslme(ji,jst)
+                mc(ji,jsl,jst) = mc(ji,jsl,jst) - excess / dpue
+             ENDDO
+             ! Then we have to check if there is no negative value 
+
+             DO jsl = 1,nslm-1
+                excess = MAX(mcr(jst)-mc(ji,jsl,jst),zero)
+                mc(ji,jsl,jst) = mc(ji,jsl,jst) + excess
+                mc(ji,jsl+1,jst) = mc(ji,jsl+1,jst) - excess * &
+                     &  (dz(jsl,jst)+dz(jsl+1,jst))/(dz(jsl+1,jst)+dz(jsl+2,jst))
+             ENDDO
+             
+             excess = MAX(mcr(jst)-mc(ji,nslm,jst),zero)
+             mc(ji,nslm,jst) = mc(ji,nslm,jst) + excess
+          
+             !- Then if the soil moisture at bottom is not sufficient, we try to refill the column from the top
+             DO jsl = nslm-1,1,-1
+                mc(ji,jsl,jst) = mc(ji,jsl,jst) - excess * &
+                     &  (dz(jsl+1,jst)+dz(jsl+2,jst))/(dz(jsl+1,jst)+dz(jsl,jst))
+                excess = MAX(mcr(jst)-mc(ji,jsl,jst),zero)
+                mc(ji,jsl,jst) = mc(ji,jsl,jst) + excess
+             ENDDO
+          
+             excess = excess * mask_soiltype(ji,jst)
+             mc(ji,:,jst) = mc(ji,:,jst) * mask_soiltype(ji,jst)
+             
+             ! And if excess is still positive, we put the soil under the residual value:
+             DO jsl = 1, nslm
+                mc(ji,jsl,jst) = mc(ji,jsl,jst) - excess / (dpu(jst) * mille)
+             ENDDO
+          ENDIF
+
+          dr_ns(ji,jst) = qflux(ji,nslm,jst) 
+
+          IF (ABS(ae_ns(ji,jst)).LT.min_sechiba) THEN
+             ae_ns(ji,jst) = zero
+          ENDIF
+
+          IF(ABS(ru_ns(ji,jst)).LT.min_sechiba) THEN
+             ru_ns(ji,jst) = zero
+          ENDIF
+
+          IF(ABS(dr_ns(ji,jst)).LT.min_sechiba) THEN
+             dr_ns(ji,jst) = zero
+          ENDIF
+
+          ! We add the evaporation to the soil profile
+
+          dpue = zz(nslme(ji,jst),jst) + dz(nslme(ji,jst)+1,jst) / deux
+          DO jsl = 1, nslme(ji,jst)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) + ae_ns(ji,jst) / dpue
+          ENDDO
+       END DO
+
+       !
+       !- Special case for saturated soil
+       !- We did not use the diffusion and just use a sort of bucket system
+
+       DO ji_nsat=1,n_sat(jst)
+          ji = index_sat(ji_nsat,jst)
+          dr_ns(ji,jst) = zero ! -returnflow_soil(ji)   
+          m_sl0 = mask_soiltype(ji,jst)
+          !
+          !- mc1 and mc2 calculation
+          ! Calculation of mc1 after last timestep evap and after precip and irrigation
+          mc(ji,1,jst) = mc(ji,1,jst) + (precisol_ns(ji,jst) + irrigation_soil(ji) - ae_ns(ji,jst)) &
+               & * 2 / dz(2,jst)
+          ! Preparing to take water from bottom in case of under-residual mc1
+          excess = MAX(mcr(jst)-mc(ji,1,jst),zero)
+          mc(ji,1,jst) = mc(ji,1,jst) + excess
+          ! Calculation of mc2 with returnflow, transpiration and probable lack of water in first layer
+          mc(ji,2,jst) = mc(ji,2,jst) + (returnflow_soil(ji) - tsink(ji) + ae_ns(ji,jst) - & 
+               & excess * dz(2,jst) / 2) * 2/(dz(2,jst) + dz(3,jst))
+          ! Shifting water to top in case of saturation (returnflow very strong)
+          excess = MAX(mc(ji,2,jst)-mcs(jst),zero)
+          mc(ji,2,jst) = mc(ji,2,jst) - excess
+          mc(ji,1,jst) = mc(ji,1,jst) + excess * (dz(2,jst) + dz(3,jst)) / dz(2,jst)
+          ! Avoiding under residual soil moisture for mc2 if transpiration was very high
+          DO jsl = 2, nslm-1
+             excess = MAX(mcr(jst)-mc(ji,jsl,jst),zero)
+             mc(ji,jsl,jst) = mc(ji,jsl,jst) + excess
+             mc(ji,jsl+1,jst) = mc(ji,jsl+1,jst) - excess * &
+                  & (dz(jsl,jst) + dz(jsl+1,jst))/(dz(jsl+1,jst) + dz(jsl+2,jst))
+          ENDDO
+          excess = m_sl0 * excess
+          mc(ji,:,jst) = m_sl0 * mc(ji,:,jst)
+          IF (excess .GT. min_sechiba) THEN
+             STOP 'Saturated soil evaporating everything... Oups...'
+          ENDIF
+          !
+          !- Deduction of ae_ns (used for next step) allowing first two layers drying out
+          ! We first calculate the water that can be evaporated from the first layer and deduce the runoff
+          ae_ns(ji,jst) = m_sl0 * MIN((mc(ji,1,jst)-mcr(jst))*dz(2,jst)/2,evapot_penm(ji)) 
+          ! Generating runoff in case of remaining over saturation in the first layer
+          excess = m_sl0 * MIN(MAX(mc(ji,1,jst)-mcs(jst),zero),mc(ji,1,jst)-mcr(jst)-ae_ns(ji,jst)*2/dz(2,jst))
+          mc(ji,1,jst) = mc(ji,1,jst) - excess
+          ru_ns(ji,jst) = m_sl0 * excess * dz(2,jst)/2
+          ! If it was not sufficient for ae_ns to reach evapot, we evaporate water from the second layer.
+          ae_ns(ji,jst) = ae_ns(ji,jst) + m_sl0 * &
+               & MIN((mc(ji,2,jst)-mcr(jst))*(dz(2,jst)+dz(3,jst))/2, evapot_penm(ji) - ae_ns(ji,jst))
+
+          ! calculation of qflux from what precedes
+          qflux00(ji,jst) = m_sl0 * (precisol_ns(ji,jst) + irrigation_soil(ji) &
+               & - ae_ns(ji,jst) - ru_ns(ji,jst))
+
+          IF (ABS(ae_ns(ji,jst)).LT.min_sechiba) THEN
+             ae_ns(ji,jst) = zero
+          ENDIF
+
+          IF(ABS(ru_ns(ji,jst)).LT.min_sechiba) THEN
+             ru_ns(ji,jst) = zero
+          ENDIF
+       ENDDO
+
+
+       !
+       !- step8: we make some useful output
+       !- Total soil moisture, soil moisture at litter levels, soil wetness...
+       ! 
+
+       !-total soil moisture:
+
+       DO ji=1,kjpindex
+          tmc(ji,jst)= dz(2,jst) * (trois*mc(ji,1,jst) + mc(ji,2,jst))/huit
+       END DO
+
+       DO jsl=2,nslm-1
+          DO ji=1,kjpindex
+             tmc(ji,jst) = tmc(ji,jst) + dz(jsl,jst) * ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
+          END DO
+       END DO
+
+       DO ji=1,kjpindex
+          tmc(ji,jst) = tmc(ji,jst) +  dz(nslm,jst) * (trois * mc(ji,nslm,jst) + mc(ji,nslm-1,jst))/huit
+       END DO
+
+       ! the litter is the 4 top levels of the soil
+       ! we compute various field of soil moisture for the litter (used for stomate and for albedo)
+
+       DO ji=1,kjpindex
+          tmc_litter(ji,jst) = dz(2,jst) * ( trois*mc(ji,1,jst)+ mc(ji,2,jst))/huit
+       END DO
+
+
+       ! sum from level 1 to 4
+
+       DO jsl=2,4
+
+          DO ji=1,kjpindex
+             tmc_litter(ji,jst) = tmc_litter(ji,jst) + dz(jsl,jst) * & 
+                  & ( trois*mc(ji,jsl,jst) + mc(ji,jsl-1,jst))/huit &
+                  & + dz(jsl+1,jst)*(trois*mc(ji,jsl,jst) + mc(ji,jsl+1,jst))/huit
+          END DO
+
+       END DO
+
+
+       ! subsequent calcul of soil_wet_litter (tmc-tmcw)/(tmcf-tmcw)
+
+       DO ji=1,kjpindex
+          soil_wet_litter(ji,jst) = MIN(un, MAX(zero,&
+               & (tmc_litter(ji,jst)-tmc_litter_wilt(ji,jst)) / &
+               & (tmc_litter_field(ji,jst)-tmc_litter_wilt(ji,jst)) ))
+       END DO
+
+       ! Soil wetness profiles (mc-mcw)/(mcs-mcw)
+       ! soil_wet is the ratio of soil moisture to available soil moisture for plant
+       ! (ie soil moisture at saturation minus soil moisture at wilting point).
+
+       DO ji=1,kjpindex
+          soil_wet(ji,1,jst) = MIN(un, MAX(zero,&
+               & (trois*mc(ji,1,jst) + mc(ji,2,jst) - quatre*mcw(jst))&
+               & /(quatre*(mcs(jst)-mcw(jst))) ))
+          humrelv(ji,1,jst) = zero
+       END DO
+
+       DO jsl=2,nslm-1
+          DO ji=1,kjpindex
+             soil_wet(ji,jsl,jst) = MIN(un, MAX(zero,&
+                  & (trois*mc(ji,jsl,jst) + & 
+                  & mc(ji,jsl-1,jst) *(dz(jsl,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
+                  & + mc(ji,jsl+1,jst)*(dz(jsl+1,jst)/(dz(jsl,jst)+dz(jsl+1,jst))) &
+                  & - quatre*mcw(jst)) / (quatre*(mcs(jst)-mcw(jst))) ))
+          END DO
+       END DO
+
+       DO ji=1,kjpindex
+          soil_wet(ji,nslm,jst) = MIN(un, MAX(zero,&
+               & (trois*mc(ji,nslm,jst) &
+               & + mc(ji,nslm-1,jst)-quatre*mcw(jst))/(quatre*(mcs(jst)-mcw(jst))) ))
+       END DO
+
+       !
+       !- step8: we make the outputs for sechiba:
+       !-we compute the moderation of transpiration due to wilting point:
+       ! moderwilt is a factor which is zero if soil moisture is below the wilting point
+       ! and is un if soil moisture is above the wilting point.
+
+
+       DO jsl=1,nslm
+          DO ji=1,kjpindex
+             moderwilt(ji,jsl,jst) = INT( MAX(soil_wet(ji,jsl,jst), zero) + un - min_sechiba )
+          END DO
+       END DO
+
+       !- we compute the new humrelv to use in sechiba:
+       !- loop on each vegetation type
+
+       humrelv(:,1,jst) = zero   
+
+       DO jv = 2,nvm
+
+          !- calcul of us for each layer and vegetation type.
+
+          DO ji=1,kjpindex
+             us(ji,jv,jst,1) = moderwilt(ji,1,jst)*MIN(un,((trois*mc(ji,1,jst) + mc(ji,2,jst)) &
+                  & /(quatre*mcs(jst)*pcent(jst))) )* (un-EXP(-humcste(jv)*dz(2,jst)/mille/deux)) &
+                  & /(un-EXP(-humcste(jv)*zz(nslm,jst)/mille))
+             us(ji,jv,jst,1) = zero
+             humrelv(ji,jv,jst) = MAX(us(ji,jv,jst,1),zero)
+          END DO
+
+          DO jsl = 2,nslm-1
+             DO ji=1,kjpindex
+                us(ji,jv,jst,jsl) =moderwilt(ji,jsl,jst)* &
+                     & MIN( un, &
+                     & ((trois*mc(ji,jsl,jst)+ &
+                     & mc(ji,jsl-1,jst)*(dz(jsl,jst)/(dz(jsl,jst)+dz(jsl+1,jst)))+ &
+                     & mc(ji,jsl+1,jst)*(dz(jsl+1,jst)/(dz(jsl,jst)+dz(jsl+1,jst)))) &
+                     & /(quatre*mcs(jst)*pcent(jst))) )* &
+                     & (EXP(-humcste(jv)*zz(jsl,jst)/mille)) * &
+                     & (EXP(humcste(jv)*dz(jsl,jst)/mille/deux) - &
+                     & EXP(-humcste(jv)*dz(jsl+1,jst)/mille/deux))/ &
+                     & (EXP(-humcste(jv)*dz(2,jst)/mille/deux) &
+                     & -EXP(-humcste(jv)*zz(nslm,jst)/mille))
+
+                us(ji,jv,jst,jsl) = MAX(us (ji,jv,jst,jsl), zero)
+                humrelv(ji,jv,jst) = MAX((humrelv(ji,jv,jst) + us(ji,jv,jst,jsl)),zero)
+             END DO
+          END DO
+
+          DO ji=1,kjpindex
+             us(ji,jv,jst,nslm) =moderwilt(ji,nslm,jst)*  &
+                  & MIN(un, &
+                  & ((trois*mc(ji,nslm,jst) + mc(ji,nslm-1,jst))  &
+                  &                    / (quatre*mcs(jst)*pcent(jst))) ) * &
+                  & (EXP(humcste(jv)*dz(nslm,jst)/mille/deux) -un) * &
+                  & EXP(-humcste(jv)*zz(nslm,jst)/mille) / &
+                  & (EXP(-humcste(jv)*dz(2,jst)/mille/deux) &
+                  & -EXP(-humcste(jv)*zz(nslm,jst)/mille))
+             us(ji,jv,jst,nslm) = MAX(us(ji,jv,jst,nslm), zero)
+             humrelv(ji,jv,jst) = MAX(zero,MIN(un, humrelv(ji,jv,jst) + us(ji,jv,jst,nslm)))
+             vegstressv(ji,jv,jst) = humrelv(ji,jv,jst)
+             humrelv(ji,jv,jst) = humrelv(ji,jv,jst) * mask_corr_veg_soil(ji,jv,jst)  
+!             IF(corr_veg_soil(ji,jv,jst).EQ.zero) THEN
+!                humrelv(ji,jv,jst) = zero
+!             ENDIF
+          END DO
+       END DO
+
+       !before closing the soil water, we check the water balance of soil
+
+       IF(check_cwrr) THEN
+          DO ji = 1,kjpindex
+             
+             deltahum = (tmc(ji,jst) - tmcold(ji))
+             diff     = precisol_ns(ji,jst)-ru_ns(ji,jst)-dr_ns(ji,jst)-tsink(ji) + irrigation_soil(ji) + returnflow_soil(ji)
+             
+             IF(abs(deltahum-diff)*mask_soiltype(ji,jst).gt.deux*allowed_err) THEN
+                
+                WRITE(numout,*) 'CWRR pat: bilan non nul',ji,jst,deltahum-diff
+                WRITE(numout,*) 'tmc,tmcold,diff',tmc(ji,jst),tmcold(ji),deltahum
+                WRITE(numout,*) 'evapot,evapot_penm,ae_ns',evapot(ji),evapot_penm(ji),ae_ns(ji,jst)
+                WRITE(numout,*) 'flux,ru_ns,qdrain,tsink,q0,precisol,excess',flux(ji),ru_ns(ji,jst), &
+                     &      dr_ns(ji,jst),tsink(ji),qflux00(ji,jst),precisol_ns(ji,jst),runoff_excess(ji,jst)
+                WRITE(numout,*) 'soiltype',soiltype(ji,jst)
+                WRITE(numout,*) 'irrigation,returnflow',irrigation_soil(ji),returnflow_soil(ji)
+                WRITE(numout,*) 'mc',mc(ji,:,jst)
+                WRITE(numout,*) 'nslme',nslme(ji,jst)
+                WRITE(numout,*) 'qflux',qflux(ji,:,jst)
+                WRITE(numout,*) 'correct,mce',correct_excess(ji),mce(ji)
+                STOP 'in hydrol_soil CWRR water balance check'
+                
+             ENDIF
+             
+             IF(MINVAL(mc(ji,:,jst)).LT.-min_sechiba) THEN
+                WRITE(numout,*) 'CWRR MC NEGATIVE', &
+                     & ji,lalo(ji,:),MINLOC(mc(ji,:,jst)),jst,mc(ji,:,jst)
+                WRITE(numout,*) 'evapot,ae_ns',evapot(ji),ae_ns(ji,jst)
+                WRITE(numout,*) 'returnflow,irrigation,nslme',returnflow_soil(ji),&
+                     & irrigation_soil(ji),nslme(ji,jst)
+                WRITE(numout,*) 'flux,ru_ns,qdrain,tsink,q0',flux(ji),ru_ns(ji,jst), &
+                     &      dr_ns(ji,jst),tsink(ji),qflux00(ji,jst)
+                WRITE(numout,*) 'soiltype',soiltype(ji,jst)
+                STOP 'in hydrol_soil CWRR MC NEGATIVE'
+             ENDIF
+          END DO
+
+          DO ji_nsat=1,n_nsat(jst)
+             ji = index_nsat(ji_nsat,jst)
+             IF (ru_ns(ji,jst).LT.-min_sechiba) THEN
+                WRITE(numout,*) 'Negative runoff in non-saturated case', ji,jst, mask_soiltype(ji,jst) 
+                WRITE(numout,*) 'mc1, mc2, nslme', mc(ji,1,jst), mc(ji,2,jst), nslme(ji,jst)
+                WRITE(numout,*) 'mcint1, mcint2, mce', mcint(ji,1), mcint(ji,2), mce(ji)
+                WRITE(numout,*) 'qflux1, correct, flux', qflux(ji,nslm,jst), correct_excess(ji), flux(ji)
+                WRITE(numout,*) 'under_mcr, test', under_mcr(ji), tmc(ji,jst)-tmcint(ji)+qflux(ji,nslm,jst)+SUM(rootsink(ji,:,jst))
+                WRITE(numout,*) 'mc', mc(ji,:,jst)
+                WRITE(numout,*) 'mcint', mcint(ji,:)
+                WRITE(numout,*) 'qflux', qflux(ji,:,jst)
+                WRITE(numout,*) 'rootsink1,evapot_penm,vegtot', rootsink(ji,1,jst), evapot_penm(ji), vegtot(ji)
+                WRITE(numout,*) 'ae_ns, tsink, returnflow, precisol_ns, irrigation, qflux0, ru_ns', &
+                     & ae_ns(ji,jst), tsink(ji), returnflow_soil(ji), &
+                     & precisol_ns(ji,jst), irrigation_soil(ji), qflux00(ji,jst), ru_ns(ji,jst)
+                STOP 'STOP in hydrol_soil: Negative runoff, non-saturated soil'
+             ENDIF
+          ENDDO
+
+          DO ji_nsat=1,n_sat(jst)
+             ji = index_sat(ji_nsat,jst)
+             m_sl0 = mask_soiltype(ji,jst)
+             IF (ru_ns(ji,jst).LT.-min_sechiba) THEN
+                WRITE(numout,*) 'Negative runoff in saturated case', ji,jst, mask_soiltype(ji,jst), &
+                     & mc(ji,1,jst), mc(ji,2,jst), ae_ns(ji,jst), tsink(ji), returnflow_soil(ji), &
+                     & precisol_ns(ji,jst), irrigation_soil(ji), qflux00(ji,jst), ru_ns(ji,jst)
+                STOP 'STOP in hydrol_soil: Negative runoff, saturated soil'
+             ENDIF
+          ENDDO
+       ENDIF
+
+    END DO  ! end of loop on soiltype
+
+    !
+    ! sum 3d variables into 2d variables
+    !
+    CALL hydrol_diag_soil (kjpindex, veget, veget_max, soiltype, runoff, drainage, &
+         & evap_bare_lim, evapot, vevapnu, returnflow, irrigation, &
+         & shumdiag, litterhumdiag, humrel, vegstress, drysoil_frac,tot_melt)
+    RETURN
+
+  END SUBROUTINE hydrol_soil
+
+  SUBROUTINE hydrol_soil_tridiag(kjpindex,ins)
+
+    !- solves a set of linear equations which has  a tridiagonal
+    !-  coefficient matrix.
+
+    !- arguments
+    INTEGER(i_std), INTENT(in)                         :: kjpindex        !! Domain size
+    INTEGER(i_std), INTENT(in)                         :: ins             !! number of soil type
+
+    !  -- variables locales
+
+    INTEGER(i_std)                      ::  ji,jt,jsl,ji_nsat
+    REAL(r_std), DIMENSION(kjpindex)                             :: bet
+
+    DO ji_nsat = 1,n_nsat(ins)
+       ji = index_nsat(ji_nsat,ins)
+
+       IF (resolv(ji)) THEN
+          bet(ji) = tmat(ji,1,2)
+          mc(ji,1,ins) = rhs(ji,1)/bet(ji)
+
+          DO jsl = 2,nslme(ji,ins)
+             gam(ji,jsl) = tmat(ji,jsl-1,3)/bet(ji)
+             bet(ji) = tmat(ji,jsl,2) - tmat(ji,jsl,1)*gam(ji,jsl)
+             mc(ji,jsl,ins) = (rhs(ji,jsl)-tmat(ji,jsl,1)*mc(ji,jsl-1,ins))/bet(ji)
+          ENDDO
+
+          DO jsl = nslme(ji,ins)-1,1,-1
+             mc(ji,jsl,ins) = mc(ji,jsl,ins) - gam(ji,jsl+1)*mc(ji,jsl+1,ins)
+          ENDDO
+       ENDIF
+    ENDDO
+    RETURN
+  END SUBROUTINE hydrol_soil_tridiag
+  
+
+  SUBROUTINE hydrol_soil_setup(kjpindex,ins,dtradia)
+
+    !
+    !**** *hydrol_soil_setup* - 
+    !**** *routine that computes the matrix coef for dublin model.
+    !**** *uses the linearised hydraulic conductivity k_lin=a_lin mc_lin+b_lin
+    !**** *and the linearised diffusivity d_lin
+    !
+    IMPLICIT NONE
+    !
+    REAL(r_std), INTENT (in)                           :: dtradia          !! Time step in seconds
+    ! parameters
+    INTEGER(i_std), INTENT(in)                        :: kjpindex         !! Domain size
+    INTEGER(i_std), INTENT(in)                        :: ins              ! index of soil type
+    ! local 
+    INTEGER(i_std) :: jsl,ji,i,m_sl0,m_sl1, ji_nsat
+    REAL(r_std), DIMENSION (nslm)      :: temp0, temp5, temp6, temp7
+    REAL(r_std)                        :: temp3, temp4
+
+    !-first, we identify the interval i in which the current value of mc is located
+    !-then, we give the values of the linearized parameters to compute 
+    ! conductivity and diffusivity as K=a*mc+b and d
+
+    DO jsl=1,nslm
+       DO ji=1,kjpindex 
+          i= MIN(INT((imax-imin)*(MAX(mc(ji,jsl,ins),mcr(ins))-mcr(ins))&
+               &         / (mcs(ins)-mcr(ins)))+imin , imax-1)
+          a(ji,jsl) = a_lin(i,ins)
+          b(ji,jsl) = b_lin(i,ins)
+          d(ji,jsl) = d_lin(i,ins)
+       ENDDO ! loop on grid
+    ENDDO
+    
+
+    !-second, we compute tridiag matrix coefficients (LEFT and RIGHT) 
+    ! of the system to solve [LEFT]*mc_{t+1}=[RIGHT]*mc{t}+[add terms]: 
+    ! e(nslm),f(nslm),g1(nslm) for the [left] vector
+    ! and ep(nslm),fp(nslm),gp(nslm) for the [right] vector
+
+    temp3 = w_time*(dtradia/one_day)/deux
+    temp4 = (un-w_time)*(dtradia/one_day)/deux
+
+    DO ji_nsat=1,n_nsat(ins)
+       ji = index_nsat(ji_nsat,ins)
+
+       !- First layer temporary calc
+       !- Be careful! The order (first layer before last) is very important in case nslme(ji,jst)=1
+       temp0(1) = trois * dz(2,ins)/huit
+       temp5(1) = zero
+       temp6(1) = (d(ji,1)+d(ji,2))/(dz(2,ins)) + a(ji,1)
+       temp7(1) = (d(ji,1)+d(ji,2))/(dz(2,ins)) - a(ji,2)
+
+       !- Main body
+       DO jsl = 2, nslme(ji,ins)-1
+          temp0(jsl) = trois *  (dz(jsl,ins) + dz(jsl+1,ins))/huit 
+          temp5(jsl) =(d(ji,jsl)+d(ji,jsl-1))/(dz(jsl,ins))+a(ji,jsl-1)
+          temp6(jsl) = (d(ji,jsl)+d(ji,jsl-1))/(dz(jsl,ins)) + &
+               & (d(ji,jsl)+d(ji,jsl+1))/(dz(jsl+1,ins))
+          temp7(jsl) = (d(ji,jsl)+d(ji,jsl+1))/(dz(jsl+1,ins)) &
+               & - a(ji,jsl+1) 
+       ENDDO
+
+       !- Last layer
+       jsl = nslme(ji,ins)
+       temp0(jsl) = trois * (dz(jsl,ins) + dz(jsl+1,ins))/huit &
+            & + dz(jsl+1,ins)/huit
+       temp5(jsl) = (d(ji,jsl)+d(ji,jsl-1)) / (dz(jsl,ins)) &
+            & + a(ji,jsl-1)
+       temp6(jsl) = (d(ji,jsl)+d(ji,jsl-1))/dz(jsl,ins) & 
+            & + a(ji,jsl) 
+       temp7(jsl) = zero
+
+       !- coefficient for every layer
+       DO jsl = 1, nslme(ji,ins)
+          e(ji,jsl) = dz(jsl,ins)/(huit)    - temp3*temp5(jsl) 
+          f(ji,jsl) = temp0(jsl)       + temp3*temp6(jsl)
+          g1(ji,jsl) = dz(jsl+1,ins)/(huit)  - temp3*temp7(jsl)
+          ep(ji,jsl) = dz(jsl,ins)/(huit)   + temp4*temp5(jsl) 
+          fp(ji,jsl) = temp0(jsl)      - temp4*temp6(jsl)  
+          gp(ji,jsl) = dz(jsl+1,ins)/(huit) + temp4*temp7(jsl)
+       ENDDO
+    ENDDO
+
+    RETURN
+  END SUBROUTINE hydrol_soil_setup
+
+  !!! fait la connexion entre l'hydrologie et sechiba :
+  !!! cherche les variables sechiba pour l'hydrologie
+  !!! "transforme" ces variables
+  SUBROUTINE hydrol_split_soil (kjpindex, veget, soiltype, vevapnu, transpir, humrel,evap_bare_lim)
+    ! 
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in)       :: veget            !! Vegetation map 
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in)      :: soiltype         !! Map of soil types
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)           :: vevapnu          !! Bare soil evaporation
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)       :: transpir         !! Transpiration
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)       :: humrel           !! Relative humidity
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)           :: evap_bare_lim   !!   
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                               :: ji, jv, jsl, jst
+    REAL(r_std), Dimension (kjpindex)             :: vevapnu_old
+    REAL(r_std), Dimension (kjpindex)             :: tmp_check1
+    REAL(r_std), Dimension (kjpindex)             :: tmp_check2
+    REAL(r_std), DIMENSION (kjpindex,nstm)        :: tmp_check3
+
+    !
+    !
+    ! split 2d variables into 3d variables, per soil type
+    !
+    precisol_ns(:,:)=zero
+    DO jv=1,nvm
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF(veget(ji,jv).GT.min_sechiba) THEN
+                precisol_ns(ji,jst)=precisol_ns(ji,jst)+precisol(ji,jv)* &
+                     & corr_veg_soil(ji,jv,jst) / veget(ji,jv)
+             ENDIF
+          END DO
+       END DO
+    END DO
+    !
+    !
+    !
+    vevapnu_old(:)=zero
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          vevapnu_old(ji)=vevapnu_old(ji)+ &
+               & ae_ns(ji,jst)*soiltype(ji,jst)*vegtot(ji)
+       END DO
+    END DO
+    !
+    !
+    !
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          IF (vevapnu_old(ji).GT.min_sechiba) THEN   
+             IF(evap_bare_lim(ji).GT.min_sechiba) THEN       
+                ae_ns(ji,jst) = vevapnu(ji) * evap_bare_lim_ns(ji,jst)/evap_bare_lim(ji)
+             ELSE
+                ae_ns(ji,jst)=ae_ns(ji,jst) * vevapnu(ji)/vevapnu_old(ji)
+             ENDIF
+          ELSEIF(veget(ji,1).GT.min_sechiba.AND.soiltype(ji,jst).GT.min_sechiba) THEN
+             IF(evap_bare_lim(ji).GT.min_sechiba) THEN  
+                ae_ns(ji,jst) = vevapnu(ji) * evap_bare_lim_ns(ji,jst)/evap_bare_lim(ji)
+             ELSE
+                ae_ns(ji,jst)=vevapnu(ji)*corr_veg_soil(ji,1,jst)/veget(ji,1)
+             ENDIF
+          ENDIF
+          precisol_ns(ji,jst)=precisol_ns(ji,jst)+MAX(-ae_ns(ji,jst),zero)
+       END DO
+    END DO
+
+    tr_ns(:,:)=zero
+    DO jv=1,nvm
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF (corr_veg_soil(ji,jv,jst).GT.min_sechiba.AND.humrel(ji,jv).GT.min_sechiba) THEN 
+                tr_ns(ji,jst)=tr_ns(ji,jst)+ corr_veg_soil(ji,jv,jst)*humrelv(ji,jv,jst)* & 
+                     & transpir(ji,jv)/(humrel(ji,jv)*veget(ji,jv))
+             ENDIF
+          END DO
+       END DO
+    END DO
+
+    rootsink(:,:,:)=zero
+    DO jv=1,nvm
+       DO jsl=1,nslm
+          DO jst=1,nstm
+             DO ji=1,kjpindex
+                IF ((humrel(ji,jv).GT.min_sechiba).AND.(corr_veg_soil(ji,jv,jst).GT.min_sechiba)) THEN 
+                   rootsink(ji,jsl,jst) = rootsink(ji,jsl,jst) &
+                        & + corr_veg_soil(ji,jv,jst)* (transpir(ji,jv)*us(ji,jv,jst,jsl))/ &
+                        & (humrel(ji,jv)*veget(ji,jv))
+                END IF
+             END DO
+          END DO
+       END DO
+    END DO
+
+    IF(check_cwrr) THEN
+       DO jsl=1,nslm
+          DO jst=1,nstm
+             DO ji=1,kjpindex
+                IF(mc(ji,jsl,jst).LT.-0.05) THEN
+                   WRITE(numout,*) 'CWRR split-----------------------------------------------'
+                   WRITE(numout,*) 'ji,jst,jsl',ji,jst,jsl
+                   WRITE(numout,*) 'mc',mc(ji,jsl,jst)
+                   WRITE(numout,*) 'rootsink,us',rootsink(ji,:,jst),us(ji,:,jst,jsl)
+                   WRITE(numout,*) 'corr_veg_soil',corr_veg_soil(ji,:,jst)
+                   WRITE(numout,*) 'transpir',transpir(ji,:)
+                   WRITE(numout,*) 'veget',veget(ji,:)
+                   WRITE(numout,*) 'humrel',humrel(ji,:)
+                   WRITE(numout,*) 'humrelv (pour ce jst)',humrelv(ji,:,jst)
+                   WRITE(numout,*) 'ae_ns',ae_ns(ji,jst)
+                   WRITE(numout,*) 'ae_ns',ae_ns(ji,jst)
+                   WRITE(numout,*) 'tr_ns',tr_ns(ji,jst)
+                   WRITE(numout,*) 'vevapnuold',vevapnu_old(ji)
+                ENDIF
+             END DO
+          END DO
+       END DO
+    ENDIF
+
+
+    ! Now we check if the deconvolution is correct and conserves the fluxes:
+
+    IF (check_cwrr) THEN
+
+
+       tmp_check1(:)=zero
+       tmp_check2(:)=zero  
+
+       ! First we check the precisol and evapnu
+
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             tmp_check1(ji)=tmp_check1(ji) + &
+                  & (precisol_ns(ji,jst)-MAX(-ae_ns(ji,jst),zero))* &
+                  & soiltype(ji,jst)*vegtot(ji)
+          END DO
+       END DO
+
+       DO jv=1,nvm
+          DO ji=1,kjpindex
+             tmp_check2(ji)=tmp_check2(ji) + precisol(ji,jv)
+          END DO
+       END DO
+
+
+       DO ji=1,kjpindex   
+
+          IF(ABS(tmp_check1(ji)- tmp_check2(ji)).GT.allowed_err) THEN
+             WRITE(numout,*) 'PRECISOL SPLIT FALSE:ji=',ji,tmp_check1(ji),tmp_check2(ji)
+             WRITE(numout,*) 'vegtot',vegtot(ji)
+
+             DO jv=1,nvm
+                WRITE(numout,*) 'jv,veget, precisol',jv,veget(ji,jv),precisol(ji,jv)
+                DO jst=1,nstm
+                   WRITE(numout,*) 'corr_veg_soil:jst',jst,corr_veg_soil(ji,jv,jst)
+                END DO
+             END DO
+
+             DO jst=1,nstm
+                WRITE(numout,*) 'jst,precisol_ns',jst,precisol_ns(ji,jst)
+                WRITE(numout,*) 'soiltype', soiltype(ji,jst)
+             END DO
+             STOP 'in hydrol_split_soil check_cwrr'
+          ENDIF
+
+       END DO
+
+
+       tmp_check1(:)=zero
+       tmp_check2(:)=zero 
+
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             tmp_check1(ji)=tmp_check1(ji) + ae_ns(ji,jst)* &
+                  & soiltype(ji,jst)*vegtot(ji)
+          END DO
+       END DO
+
+       DO ji=1,kjpindex   
+
+          IF(ABS(tmp_check1(ji)- vevapnu(ji)).GT.allowed_err) THEN
+             WRITE(numout,*) 'VEVAPNU SPLIT FALSE:ji, Sum(ae_ns), vevapnu =',ji,tmp_check1(ji),vevapnu(ji)
+             WRITE(numout,*) 'vegtot',vegtot(ji)
+             WRITE(numout,*) 'evap_bare_lim, evap_bare_lim_ns',evap_bare_lim(ji), evap_bare_lim_ns(ji,:)
+             WRITE(numout,*) 'vevapnu_old',vevapnu_old(ji)
+             DO jst=1,nstm
+                WRITE(numout,*) 'jst,ae_ns',jst,ae_ns(ji,jst)
+                WRITE(numout,*) 'soiltype', soiltype(ji,jst)
+             END DO
+             STOP 'in hydrol_split_soil check_cwrr'
+          ENDIF
+       ENDDO
+
+       ! Second we check the transpiration and root sink
+
+       tmp_check1(:)=zero
+       tmp_check2(:)=zero  
+
+
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             tmp_check1(ji)=tmp_check1(ji) + tr_ns(ji,jst)* &
+                  & soiltype(ji,jst)*vegtot(ji)
+          END DO
+       END DO
+
+       DO jv=1,nvm
+          DO ji=1,kjpindex
+             tmp_check2(ji)=tmp_check2(ji) + transpir(ji,jv)
+          END DO
+       END DO
+
+       DO ji=1,kjpindex   
+
+          IF(ABS(tmp_check1(ji)- tmp_check2(ji)).GT.allowed_err) THEN
+             WRITE(numout,*) 'TRANSPIR SPLIT FALSE:ji=',ji,tmp_check1(ji),tmp_check2(ji)
+             WRITE(numout,*) 'vegtot',vegtot(ji)
+
+             DO jv=1,nvm
+                WRITE(numout,*) 'jv,veget, transpir',jv,veget(ji,jv),transpir(ji,jv)
+                DO jst=1,nstm
+                   WRITE(numout,*) 'corr_veg_soil:ji,jv,jst',ji,jv,jst,corr_veg_soil(ji,jv,jst)
+                END DO
+             END DO
+
+             DO jst=1,nstm
+                WRITE(numout,*) 'jst,tr_ns',jst,tr_ns(ji,jst)
+                WRITE(numout,*) 'soiltype', soiltype(ji,jst)
+             END DO
+
+             STOP 'in hydrol_split_soil check_cwrr'
+          ENDIF
+
+       END DO
+
+
+       tmp_check3(:,:)=zero
+
+       DO jst=1,nstm
+          DO jsl=1,nslm
+             DO ji=1,kjpindex
+                tmp_check3(ji,jst)=tmp_check3(ji,jst) + rootsink(ji,jsl,jst)
+             END DO
+          END DO
+       ENDDO
+
+       DO jst=1,nstm
+          DO ji=1,kjpindex
+             IF(ABS(tmp_check3(ji,jst)- tr_ns(ji,jst)).GT.allowed_err) THEN
+                WRITE(numout,*) 'ROOTSINK SPLIT FALSE:ji,jst=', ji,jst,&
+                     & tmp_check3(ji,jst),tr_ns(ji,jst)
+                WRITE(numout,*) 'HUMREL(jv=1:13)',humrel(ji,:)
+                WRITE(numout,*) 'TRANSPIR',transpir(ji,:)
+                DO jv=1,nvm 
+                   WRITE(numout,*) 'jv=',jv,'us=',us(ji,jv,jst,:)
+                ENDDO
+                STOP 'in hydrol_split_soil check_cwrr'
+             ENDIF
+          END DO
+       END DO
+
+    ENDIF
+
+    RETURN 
+
+  END SUBROUTINE hydrol_split_soil
+
+  SUBROUTINE hydrol_diag_soil (kjpindex, veget, veget_max,soiltype, runoff, drainage, &
+       & evap_bare_lim, evapot, vevapnu, returnflow, irrigation, &
+       & shumdiag, litterhumdiag, humrel, vegstress, drysoil_frac, tot_melt)
+    ! 
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)       :: veget           !! Map of vegetation types
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)        :: veget_max       !! Max. vegetation type
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT (in)      :: soiltype        !! Map of soil types
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: drysoil_frac    !! Function of litter wetness
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: runoff          !! complete runoff
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: drainage        !! Drainage
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: evap_bare_lim   !! 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: evapot          !! 
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu  
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: returnflow       !! Water returning to the deep reservoir
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: irrigation      !! Water from irrigation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: tot_melt
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out)      :: shumdiag        !! relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: litterhumdiag   !! litter humidity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)       :: humrel          !! Relative humidity
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out)    :: vegstress       !! Veg. moisture stress (only for vegetation growth)
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                :: ji, jv, jsl, jst
+    REAL(r_std), DIMENSION (kjpindex)                                    :: mask_vegtot
+    !
+    ! Put the prognostics variables of soil to zero if soiltype is zero
+
+    DO jst=1,nstm 
+
+       DO ji=1,kjpindex
+
+!          IF(soiltype(ji,jst).EQ.zero) THEN
+
+             ae_ns(ji,jst) = ae_ns(ji,jst) * mask_soiltype(ji,jst)
+             dr_ns(ji,jst) = dr_ns(ji,jst) * mask_soiltype(ji,jst)
+             ru_ns(ji,jst) = ru_ns(ji,jst) * mask_soiltype(ji,jst)
+             tmc(ji,jst) =  tmc(ji,jst) * mask_soiltype(ji,jst)
+
+             DO jv=1,nvm
+                humrelv(ji,jv,jst) = humrelv(ji,jv,jst) * mask_soiltype(ji,jst)
+                DO jsl=1,nslm
+                   us(ji,jv,jst,jsl) = us(ji,jv,jst,jsl)  * mask_soiltype(ji,jst)
+                END DO
+             END DO
+
+             DO jsl=1,nslm          
+                mc(ji,jsl,jst) = mc(ji,jsl,jst)  * mask_soiltype(ji,jst)
+             END DO
+
+!          ENDIF
+
+       END DO
+    END DO
+
+
+    runoff(:) = zero
+    drainage(:) = zero
+    humtot(:) = zero
+    evap_bare_lim(:) = zero
+    evap_bare_lim_ns(:,:) = zero
+    shumdiag(:,:)= zero
+    litterhumdiag(:) = zero
+    tmc_litt_mea(:) = zero
+    soilmoist(:,:) = zero
+    humrel(:,:) = zero
+    vegstress(:,:) = zero
+    !
+    ! sum 3d variables in 2d variables with fraction of vegetation per soil type
+    !
+
+
+    DO ji = 1, kjpindex
+!         WRITE(numout,*) ' kjpindex',kjpindex,ji,vegtot(ji)
+!        mask_vegtot = MIN( un, MAX(zero,vegtot(ji) ) )
+          mask_vegtot(ji) = 0
+          IF(vegtot(ji) .GT. min_sechiba) THEN
+           mask_vegtot(ji) = 1
+          ENDIF
+     END DO           
+
+      DO ji = 1, kjpindex 
+!        WRITE(numout,*) 'vegtot,mask_vegtot',ji,vegtot(ji),mask_vegtot(ji)
+        ae_ns(ji,:) = mask_vegtot(ji) * ae_ns(ji,:)  * corr_veg_soil(ji,1,:)
+           DO jst = 1, nstm
+             drainage(ji) = mask_vegtot(ji) * (drainage(ji) + vegtot(ji)*soiltype(ji,jst) * dr_ns(ji,jst))
+             runoff(ji) = mask_vegtot(ji) *  (runoff(ji) +   vegtot(ji)*soiltype(ji,jst) * ru_ns(ji,jst)) &
+                  & + (1 - mask_vegtot(ji)) * (tot_melt(ji) + irrigation(ji) + returnflow(ji))
+             humtot(ji) = mask_vegtot(ji) * (humtot(ji) + soiltype(ji,jst) * tmc(ji,jst))
+           END DO
+    END DO
+
+    DO jst=1,nstm
+       DO ji=1,kjpindex
+          IF ((evapot(ji).GT.min_sechiba) .AND. &
+               & (tmc_litter(ji,jst).GT.(tmc_litter_wilt(ji,jst)))) THEN
+             evap_bare_lim_ns(ji,jst) = ae_ns(ji,jst) / evapot(ji)
+          ELSEIF((evapot(ji).GT.min_sechiba).AND. &
+               & (tmc_litter(ji,jst).GT.(tmc_litter_res(ji,jst)))) THEN
+             evap_bare_lim_ns(ji,jst) =  (un/deux) * ae_ns(ji,jst) / evapot(ji)
+          END IF
+
+       END DO
+    END DO
+
+     DO ji = 1, kjpindex
+         evap_bare_lim(ji) =   SUM(evap_bare_lim_ns(ji,:)*vegtot(ji)*soiltype(ji,:))
+        IF(evap_bare_lim(ji).GT.un + min_sechiba) THEN
+           WRITE(numout,*) 'CWRR DIAG EVAP_BARE_LIM TOO LARGE', ji, &
+                & evap_bare_lim(ji),evap_bare_lim_ns(ji,:)
+        ENDIF 
+        !print *,'HYDROL_DIAG: ji,evap_bare_lim,evap_bare_lim_ns',ji,evap_bare_lim(ji),evap_bare_lim_ns(ji,:)
+     ENDDO
+    ! we add the excess of snow sublimation to vevapnu
+
+    DO ji = 1,kjpindex
+       vevapnu(ji) = vevapnu (ji) + subsinksoil(ji)*vegtot(ji)
+    END DO
+
+    DO jst=1,nstm
+       DO jv=1,nvm
+          DO ji=1,kjpindex
+             IF(veget_max(ji,jv).GT.min_sechiba) THEN
+             vegstress(ji,jv)=vegstress(ji,jv)+vegstressv(ji,jv,jst)*soiltype(ji,jst) &
+                & * corr_veg_soil_max(ji,jv,jst) *vegtot(ji)/veget_max(ji,jv)
+             vegstress(ji,jv)= MAX(vegstress(ji,jv),zero)
+             ENDIF
+
+             IF(veget(ji,jv).GT.min_sechiba) THEN
+                humrel(ji,jv)=humrel(ji,jv)+humrelv(ji,jv,jst)*soiltype(ji,jst) &
+                     & * corr_veg_soil(ji,jv,jst)*vegtot(ji)/veget(ji,jv)
+                humrel(ji,jv)=MAX(humrel(ji,jv),zero)
+             ENDIF
+          END DO
+       END DO
+    END DO
+
+!    vegstress(:,:) =  humrel(:,:)
+
+
+    DO jst=1,nstm        
+
+       DO ji=1,kjpindex
+          litterhumdiag(ji) = litterhumdiag(ji) + &
+               & soil_wet_litter(ji,jst) * soiltype(ji,jst)
+
+          tmc_litt_mea(ji) = tmc_litt_mea(ji) + &
+               & tmc_litter(ji,jst) * soiltype(ji,jst) 
+
+       END DO
+
+
+       DO jsl=1,nbdl
+          DO ji=1,kjpindex
+             shumdiag(ji,jsl)= shumdiag(ji,jsl) + soil_wet(ji,jsl,jst) * &
+                  & ((mcs(jst)-mcw(jst))/(mcf(jst)-mcw(jst))) * &
+                  & soiltype(ji,jst)
+             soilmoist(ji,jsl)=soilmoist(ji,jsl)+mc(ji,jsl,jst)*soiltype(ji,jst)
+             shumdiag(ji,jsl) = MAX(MIN(shumdiag(ji,jsl), un), zero) 
+          END DO
+       END DO
+
+
+    END DO
+
+
+    DO ji=1,kjpindex
+       drysoil_frac(ji) = un + MAX( MIN( (tmc_litt_dry_mea(ji) - tmc_litt_mea(ji)) / &
+            & (tmc_litt_wet_mea(ji) - tmc_litt_dry_mea(ji)), zero), - un)
+    END DO
+
+
+
+
+
+  END SUBROUTINE hydrol_diag_soil
+
+  !!
+  !! This routines checks the water balance. First it gets the total
+  !! amount of water and then it compares the increments with the fluxes.
+  !! The computation is only done over the soil area as over glaciers (and lakes?)
+  !! we do not have water conservation.
+  !!
+  !! This verification does not make much sense in REAL*4 as the precision is the same as some
+  !! of the fluxes
+  !!
+  SUBROUTINE hydrol_waterbal (kjpindex, index, first_call, dtradia, veget, totfrac_nobio, &
+       & qsintveg, snow,snow_nobio, precip_rain, precip_snow, returnflow, irrigation, tot_melt, &
+       & vevapwet, transpir, vevapnu, vevapsno, runoff, drainage)
+    !
+    !
+    !
+    INTEGER(i_std), INTENT (in)                        :: kjpindex     !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: index        !! Indeces of the points on the map
+    LOGICAL, INTENT (in)                              :: first_call   !! At which time is this routine called ?
+    REAL(r_std), INTENT (in)                           :: dtradia      !! Time step in seconds
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget        !! Fraction of vegetation type 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: totfrac_nobio!! Total fraction of continental ice+lakes+...
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintveg     !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow         !! Snow mass [Kg/m^2]
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(in)  :: snow_nobio    !!Ice water balance
+    !
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_rain  !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_snow  !! Snow precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: returnflow   !! Water from irrigation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: irrigation   !! Water from irrigation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: tot_melt     !! Total melt
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vevapwet     !! Interception loss
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: transpir     !! Transpiration
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: vevapnu      !! Bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: vevapsno     !! Snow evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)       :: runoff       !! complete runoff
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: drainage     !! Drainage
+    !
+    !  LOCAL
+    !
+    INTEGER(i_std) :: ji
+    REAL(r_std) :: watveg, delta_water, tot_flux
+    !
+    !
+    !
+    IF ( first_call ) THEN
+
+       tot_water_beg(:) = zero
+
+       DO ji = 1, kjpindex
+          watveg = SUM(qsintveg(ji,:))
+          tot_water_beg(ji) = humtot(ji)*vegtot(ji) + watveg + snow(ji)&
+               & + SUM(snow_nobio(ji,:))
+       ENDDO
+
+       tot_water_end(:) = tot_water_beg(:)
+
+
+       RETURN
+
+    ENDIF
+    !
+    !  Check the water balance
+    !
+    tot_water_end(:) = zero
+    !
+    DO ji = 1, kjpindex
+       !
+       ! If the fraction of ice, lakes, etc. does not complement the vegetation fraction then we do not
+       ! need to go any further
+       !
+       IF ( ABS(un - (totfrac_nobio(ji) + vegtot(ji))) .GT. allowed_err ) THEN
+          WRITE(numout,*) 'HYDROL problem in vegetation or frac_nobio on point ', ji
+          WRITE(numout,*) 'totfrac_nobio : ', totfrac_nobio(ji)
+          WRITE(numout,*) 'vegetation fraction : ', vegtot(ji)
+          STOP 'in hydrol_waterbal'
+       ENDIF
+       !
+       watveg = SUM(qsintveg(ji,:))
+       tot_water_end(ji) = humtot(ji)*vegtot(ji) + watveg + &
+            & snow(ji) + SUM(snow_nobio(ji,:))
+       !
+       delta_water = tot_water_end(ji) - tot_water_beg(ji)
+       !
+       tot_flux =  precip_rain(ji) + precip_snow(ji) + irrigation (ji) - &
+            & SUM(vevapwet(ji,:)) - SUM(transpir(ji,:)) - vevapnu(ji) - vevapsno(ji) - &
+            & runoff(ji) - drainage(ji) + returnflow(ji)
+       !
+       !  Set some precision ! This is a wild guess and corresponds to what works on an IEEE machine
+       !  under double precision (REAL*8).
+       !
+       !
+       IF ( ABS(delta_water-tot_flux) .GT. deux*allowed_err ) THEN
+          WRITE(numout,*) '------------------------------------------------------------------------- '
+          WRITE(numout,*) 'HYDROL does not conserve water. The erroneous point is : ', ji
+          WRITE(numout,*) 'The error in mm/s is :', (delta_water-tot_flux)/dtradia, ' and in mm/dt : ', delta_water-tot_flux
+          WRITE(numout,*) 'delta_water : ', delta_water, ' tot_flux : ', tot_flux
+          WRITE(numout,*) 'Actual and allowed error : ', ABS(delta_water-tot_flux), allowed_err
+          WRITE(numout,*) 'vegtot : ', vegtot(ji)
+          WRITE(numout,*) 'precip_rain : ', precip_rain(ji)
+          WRITE(numout,*) 'precip_snow : ',  precip_snow(ji)
+          WRITE(numout,*) 'Water from irrigation : ', returnflow(ji),irrigation(ji)
+          WRITE(numout,*) 'Total water in soil :',  humtot(ji)
+          WRITE(numout,*) 'Water on vegetation :', watveg
+          WRITE(numout,*) 'Snow mass :', snow(ji)
+          WRITE(numout,*) 'Snow mass on ice :', SUM(snow_nobio(ji,:))
+          WRITE(numout,*) 'Melt water :', tot_melt(ji)
+          WRITE(numout,*) 'evapwet : ', vevapwet(ji,:)
+          WRITE(numout,*) 'transpir : ', transpir(ji,:)
+          WRITE(numout,*) 'evapnu, evapsno : ', vevapnu(ji), vevapsno(ji)
+          WRITE(numout,*) 'drainage,runoff : ', drainage(ji),runoff(ji)
+          STOP 'in hydrol_waterbal'
+       ENDIF
+       !
+    ENDDO
+    !
+    ! Transfer the total water amount at the end of the current timestep top the begining of the next one.
+    !
+    tot_water_beg = tot_water_end
+    !
+  END SUBROUTINE hydrol_waterbal
+  !
+  !  This routine computes the changes in soil moisture and interception storage for the ALMA outputs
+  !
+  SUBROUTINE hydrol_alma (kjpindex, index, first_call, qsintveg, snow, snow_nobio, soilwet)
+    !
+    INTEGER(i_std), INTENT (in)                        :: kjpindex     !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: index        !! Indeces of the points on the map
+    LOGICAL, INTENT (in)                              :: first_call   !! At which time is this routine called ?
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintveg     !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow         !! Snow water equivalent
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: soilwet     !! Soil wetness
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio     !! Water balance on ice, lakes, .. [Kg/m^2]
+    !
+    !  LOCAL
+    !
+    INTEGER(i_std) :: ji
+    REAL(r_std) :: watveg
+    !
+    !
+    !
+    IF ( first_call ) THEN
+
+       tot_watveg_beg(:) = zero
+       tot_watsoil_beg(:) = zero
+       snow_beg(:)        = zero
+       !
+       DO ji = 1, kjpindex
+          watveg = SUM(qsintveg(ji,:))
+          tot_watveg_beg(ji) = watveg
+          tot_watsoil_beg(ji) = humtot(ji)
+          snow_beg(ji)        = snow(ji)+ SUM(snow_nobio(ji,:))
+       ENDDO
+       !
+       tot_watveg_end(:) = tot_watveg_beg(:)
+       tot_watsoil_end(:) = tot_watsoil_beg(:)
+       snow_end(:)        = snow_beg(:)
+
+       RETURN
+
+    ENDIF
+    !
+    ! Calculate the values for the end of the time step
+    !
+    tot_watveg_end(:) = zero
+    tot_watsoil_end(:) = zero
+    snow_end(:) = zero
+    delintercept(:) = zero
+    delsoilmoist(:) = zero
+    delswe(:) = zero
+    !
+    DO ji = 1, kjpindex
+       watveg = SUM(qsintveg(ji,:))
+       tot_watveg_end(ji) = watveg
+       tot_watsoil_end(ji) = humtot(ji)
+       snow_end(ji) = snow(ji)+ SUM(snow_nobio(ji,:))
+       !
+       delintercept(ji) = tot_watveg_end(ji) - tot_watveg_beg(ji)
+       delsoilmoist(ji) = tot_watsoil_end(ji) - tot_watsoil_beg(ji)
+       delswe(ji)       = snow_end(ji) - snow_beg(ji)
+       !
+       !
+    ENDDO
+    !
+    !
+    ! Transfer the total water amount at the end of the current timestep top the begining of the next one.
+    !
+    tot_watveg_beg = tot_watveg_end
+    tot_watsoil_beg = tot_watsoil_end
+    snow_beg(:) = snow_end(:)
+    !
+    DO ji = 1,kjpindex
+       soilwet(ji) = tot_watsoil_end(ji) / mx_eau_var(ji)
+    ENDDO
+    !
+  END SUBROUTINE hydrol_alma
+  !
+  !
+END MODULE hydrol
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/hydrolc.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/hydrolc.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/hydrolc.f90	(revision 55)
@@ -0,0 +1,2587 @@
+!!
+!! This module computes hydrologic processes on continental points.
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!! 
+MODULE hydrolc
+  !
+  !
+  ! routines called : restput, restget
+  !
+  USE ioipsl
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_soil
+  USE constantes_veg
+  USE sechiba_io
+  USE grid
+  USE parallel
+!  USE Write_Field_p
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! hydrol
+  PRIVATE
+  PUBLIC :: hydrolc_main,hydrolc_clear 
+
+  !
+  ! variables used inside hydrol module : declaration and initialisation
+  !
+  LOGICAL, SAVE                                     :: l_first_hydrol=.TRUE. !! Initialisation has to be done one time
+  !
+  LOGICAL, SAVE                                     :: check_waterbal=.FALSE. !! The check the water balance
+  LOGICAL, SAVE                                     :: ok_hdiff         !! do horizontal diffusion?
+
+  CHARACTER(LEN=80) , SAVE                          :: var_name         !! To store variables names for I/O
+
+  ! one dimension array allocated, computed, saved and got in hydrol module
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: bqsb             !! Hauteur d'eau dans le reservoir profond
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: gqsb             !! Hauteur d'eau dans le reservoir de surface
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: dsg              !! Hauteur du reservoir de surface
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: dsp              !! Hauteur au dessus du reservoir profond 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: mean_bqsb        !! diagnostique du reservoir profond
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: mean_gqsb        !! diagnostique du reservoir de surface
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_water_beg    !! Total amount of water at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_water_end    !! Total amount of water at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watveg_beg   !! Total amount of water on vegetation at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watveg_end   !! Total amount of water on vegetation at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watsoil_beg  !! Total amount of water in the soil at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: tot_watsoil_end  !! Total amount of water in the soil at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snow_beg         !! Total amount of snow at start of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snow_end         !! Total amount of snow at end of time step
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delsoilmoist     !! Change in soil moisture
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delintercept     !! Change in interception storage 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: delswe           !! Change in SWE
+
+  ! one dimension array allocated, computed and used in hydrol module exclusively
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: dss              !! Hauteur au dessus du reservoir de surface
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: hdry             !! Dry soil heigth in meters
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: precisol         !! Eau tombee sur le sol
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: subsnowveg       !! Sublimation of snow on vegetation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: subsnownobio     !! Sublimation of snow on other surface types (ice, lakes, ...)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: snowmelt         !! Quantite de neige fondue
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: icemelt          !! Quantite de glace fondue
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: gdrainage        !! Drainage between reservoirs
+
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: vegtot           !! Total  vegetation
+  ! The last vegetation map which was used to distribute the reservoirs
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: resdist          !! Distribution of reservoirs
+
+  !! profondeur du reservoir contenant le maximum d'eau  
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: mx_eau_var   
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: ruu_ch           !! Quantite d'eau maximum
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: runoff           !! Ruissellement
+
+  ! Ajout Nathalie - le 28 Mars 2006 - sur conseils Fred Hourdin
+  ! Modifs stabilite
+  REAL(r_std), PARAMETER                        :: dsg_min = 0.001
+
+CONTAINS
+
+  !! 
+  !! Main routine for *hydrol* module
+  !! - called only one time for initialisation
+  !! - called every time step
+  !! - called one more time at last time step for writing _restart_ file
+  !!
+  !! Algorithm:
+  !! - call hydrolc_snow for snow process (including age of snow)
+  !! - call hydrolc_canop for canopy process
+  !! - call hydrolc_soil for bare soil process
+  !!
+  !! @call hydrolc_snow
+  !! @call hydrolc_canop
+  !! @call hydrolc_soil
+  !!
+  SUBROUTINE hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
+     & temp_sol_new, run_off_tot, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+     & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, tot_melt, transpir, &
+     & precip_rain, precip_snow, returnflow, irrigation, humrel, vegstress, rsol, drysoil_frac, evapot, evapot_corr,&
+     & shumdiag, litterhumdiag, soilcap, rest_id, hist_id, hist2_id)   
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                         :: kjit             !! Time step number 
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size
+    INTEGER(i_std),INTENT (in)                         :: rest_id,hist_id  !! _Restart_ file and _history_ file identifier
+    INTEGER(i_std),INTENT (in)                         :: hist2_id         !! _history_ file 2 identifier
+    REAL(r_std), INTENT (in)                           :: dtradia          !! Time step in seconds
+    LOGICAL, INTENT(in)                               :: ldrestart_read   !! Logical for _restart_ file to read
+    LOGICAL, INTENT(in)                               :: ldrestart_write  !! Logical for _restart_ file to write
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)     :: index            !! Indeces of the points on the map
+    INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in) :: indexveg         !! Indeces of the points on the 3D map
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_rain      !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_snow      !! Snow precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: returnflow       !! Routed water which comes back into the soil
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: irrigation        !! Water from irrigation returning to soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol_new     !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: frac_nobio     !! Fraction of ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: totfrac_nobio    !! Total fraction of ice+lakes+...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: soilcap          !! Soil capacity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vevapwet         !! Interception loss
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget            !! Fraction of vegetation type           
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max        !! Max. fraction of vegetation type (LAI -> infty)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintmax         !! Maximum water on vegetation for interception
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: transpir         !! Transpiration
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot           !! Soil Potential Evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: evapot_corr !! Soil Potential Evaporation Correction
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: vevapnu          !! Bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: vevapsno         !! Snow evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: snow             !! Snow mass [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: snow_age         !! Snow age
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio     !! Water balance on ice, lakes, .. [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout) :: snow_nobio_age !! Snow age on ice, lakes, ...
+    !! We consider that any water on the ice is snow and we only peforme a water balance to have consistency.
+    !! The water balance is limite to + or - 10^6 so that accumulation is not endless
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: humrel        !! Relative humidity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: vegstress     !! Veg. moisture stress (only for vegetation growth)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout) :: qsintveg      !! Water on vegetation due to interception
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: run_off_tot   !! Complete runoff
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)     :: drainage      !! Drainage
+
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: rsol          !! Resistence to bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drysoil_frac  !! Fraction of visibly dry soil (between 0 and 1)
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout):: shumdiag      !! relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: litterhumdiag !! litter humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: tot_melt      !! Total melt    
+
+    !
+    ! local declaration
+    !
+    REAL(r_std),DIMENSION (kjpindex)                   :: soilwet          !! A temporary diagnostic of soil wetness
+    REAL(r_std),DIMENSION (kjpindex)                   :: snowdepth        !! Depth of snow layer
+
+    INTEGER(i_std)                                     :: ji,jv
+    REAL(r_std), DIMENSION(kjpindex)                   :: histvar          !! computations for history files
+
+    !
+    ! do initialisation
+    !
+    IF (l_first_hydrol) THEN
+
+        IF (long_print) WRITE (numout,*) ' l_first_hydrol : call hydrolc_init '
+
+        CALL hydrolc_init (kjit, ldrestart_read, kjpindex, index, rest_id, veget, humrel, vegstress, &
+             & snow, snow_age, snow_nobio, snow_nobio_age, qsintveg) 
+
+        CALL hydrolc_var_init (kjpindex, veget, veget_max, rsol, drysoil_frac, mx_eau_var, ruu_ch, shumdiag, litterhumdiag)
+        !
+        ! If we check the water balance we first save the total amount of water
+        !
+        IF (check_waterbal) THEN
+           CALL hydrolc_waterbal(kjpindex, index, .TRUE., dtradia, veget, totfrac_nobio, qsintveg, snow, snow_nobio,&
+                & precip_rain, precip_snow, returnflow, irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno,&
+                & run_off_tot, drainage)
+        ENDIF
+        !
+        IF (almaoutput) THEN
+           CALL hydrolc_alma(kjpindex, index, .TRUE., qsintveg, snow, snow_nobio, soilwet)
+        ENDIF
+
+        !
+        ! shared time step
+        !
+        IF (long_print) WRITE (numout,*) 'hydrolc pas de temps = ',dtradia
+
+        RETURN
+
+    ENDIF
+
+    !
+    ! prepares restart file for the next simulation
+    !
+    IF (ldrestart_write) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to complete restart file with HYDROLOGIC variables '
+
+        var_name= 'humrel'  
+	CALL restput_p(rest_id, var_name, nbp_glo,   nvm, 1, kjit,  humrel, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'vegstress'  
+	CALL restput_p(rest_id, var_name, nbp_glo,   nvm, 1, kjit,  vegstress, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'snow'    
+	CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  snow, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'snow_age'
+	CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  snow_age, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'snow_nobio'    
+	CALL restput_p(rest_id, var_name, nbp_glo, nnobio, 1, kjit,  snow_nobio, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'snow_nobio_age'
+	CALL restput_p(rest_id, var_name, nbp_glo, nnobio, 1, kjit, snow_nobio_age, 'scatter', nbp_glo, index_g)
+        !
+        var_name= 'bqsb'    
+	CALL restput_p(rest_id, var_name, nbp_glo,   nvm, 1, kjit,  bqsb, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'gqsb'   
+	CALL restput_p(rest_id, var_name, nbp_glo,   nvm, 1, kjit,  gqsb, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'dsg'     
+	CALL restput_p(rest_id, var_name, nbp_glo,  nvm, 1, kjit,  dsg, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'dsp'    
+	CALL restput_p(rest_id, var_name, nbp_glo,   nvm, 1, kjit,  dsp, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'dss'    
+	CALL restput_p(rest_id, var_name, nbp_glo,   nvm, 1, kjit,  dss, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'hdry'    
+	CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  hdry, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'qsintveg'
+	CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit,  qsintveg, 'scatter',  nbp_glo, index_g)
+        !
+        var_name= 'resdist'
+	CALL restput_p(rest_id, var_name, nbp_glo, nvm, 1, kjit,  resdist, 'scatter',  nbp_glo, index_g)
+        RETURN
+        !
+    END IF
+
+    ! 
+    ! computes snow
+    !
+
+    CALL hydrolc_snow(kjpindex, dtradia, precip_rain, precip_snow, temp_sol_new, soilcap, &
+         & frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
+         & tot_melt, snowdepth)
+    !
+    ! computes canopy
+    !
+    !
+    CALL hydrolc_vegupd(kjpindex, veget, ruu_ch, qsintveg, gqsb, bqsb, dsg, dss,dsp, resdist)
+    !
+    CALL hydrolc_canop(kjpindex, precip_rain, vevapwet, veget, qsintmax, qsintveg, precisol)
+    !
+    ! computes hydro_soil
+    !
+    CALL hydrolc_soil(kjpindex, vevapnu, precisol, returnflow, irrigation, tot_melt, mx_eau_var, veget, ruu_ch, transpir,&
+         & gqsb, bqsb, dsg, dss, rsol, drysoil_frac, hdry, dsp, runoff, run_off_tot, drainage, humrel, vegstress, &
+         & shumdiag, litterhumdiag)
+    !
+    ! computes horizontal diffusion between the water reservoirs
+    !
+    IF ( ok_hdiff ) THEN
+      CALL hydrolc_hdiff(kjpindex, dtradia, veget, ruu_ch, gqsb, bqsb, dsg, dss, dsp)
+    ENDIF
+    !
+    ! If we check the water balance we end with the comparison of total water change and fluxes
+    !
+    IF (check_waterbal) THEN
+       CALL hydrolc_waterbal(kjpindex, index, .FALSE., dtradia, veget, totfrac_nobio, qsintveg, snow, snow_nobio,&
+            & precip_rain, precip_snow, returnflow, irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno,&
+            & run_off_tot, drainage )
+    ENDIF
+    !
+    ! If we use the ALMA standards
+    !
+    IF (almaoutput) THEN
+       CALL hydrolc_alma(kjpindex, index, .FALSE., qsintveg, snow, snow_nobio, soilwet)
+    ENDIF
+
+    !
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite(hist_id, 'dss', kjit, dss, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'bqsb', kjit, mean_bqsb, kjpindex, index)
+       CALL histwrite(hist_id, 'gqsb', kjit, mean_gqsb, kjpindex, index)
+       CALL histwrite(hist_id, 'runoff', kjit, run_off_tot, kjpindex, index)
+       CALL histwrite(hist_id, 'drainage', kjit, drainage, kjpindex, index)
+       CALL histwrite(hist_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'rain', kjit, precip_rain, kjpindex, index)
+       CALL histwrite(hist_id, 'snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite(hist_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+
+       histvar(:)=zero
+       DO jv = 1, nvm
+          DO ji = 1, kjpindex
+             IF ( vegtot(ji) .GT. zero ) THEN
+                histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*mx_eau_eau, zero)
+             ENDIF
+          ENDDO
+       ENDDO
+       CALL histwrite(hist_id, 'mrsos', kjit, histvar, kjpindex, index)
+
+       histvar(:)=mean_bqsb(:)+mean_gqsb(:)
+       CALL histwrite(hist_id, 'mrso', kjit, histvar, kjpindex, index)
+
+       histvar(:)=run_off_tot(:)/one_day
+       CALL histwrite(hist_id, 'mrros', kjit, histvar, kjpindex, index)
+
+       histvar(:)=(run_off_tot(:)+drainage(:))/one_day
+       CALL histwrite(hist_id, 'mrro', kjit, histvar, kjpindex, index)
+
+       histvar(:)=(precip_rain(:)-SUM(precisol(:,:),dim=2))/one_day
+       CALL histwrite(hist_id, 'prveg', kjit, histvar, kjpindex, index)
+
+    ELSE
+       CALL histwrite(hist_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+       CALL histwrite(hist_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+       CALL histwrite(hist_id, 'Qs', kjit, run_off_tot, kjpindex, index)
+       CALL histwrite(hist_id, 'Qsb', kjit, drainage, kjpindex, index)
+       CALL histwrite(hist_id, 'Qsm', kjit, tot_melt, kjpindex, index)
+       CALL histwrite(hist_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+       CALL histwrite(hist_id, 'DelSWE', kjit, delswe, kjpindex, index)
+       CALL histwrite(hist_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
+       !
+       CALL histwrite(hist_id, 'SoilMoist', kjit, tot_watsoil_end, kjpindex, index)
+       CALL histwrite(hist_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+       CALL histwrite(hist_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+       !
+       CALL histwrite(hist_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+       CALL histwrite(hist_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+       !
+       CALL histwrite(hist_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+       !
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite(hist2_id, 'dss', kjit, dss, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'bqsb', kjit, mean_bqsb, kjpindex, index)
+          CALL histwrite(hist2_id, 'gqsb', kjit, mean_gqsb, kjpindex, index)
+          CALL histwrite(hist2_id, 'runoff', kjit, run_off_tot, kjpindex, index)
+          CALL histwrite(hist2_id, 'drainage', kjit, drainage, kjpindex, index)
+          CALL histwrite(hist2_id, 'precisol', kjit, precisol, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'rain', kjit, precip_rain, kjpindex, index)
+          CALL histwrite(hist2_id, 'snowf', kjit, precip_snow, kjpindex, index)
+          CALL histwrite(hist2_id, 'qsintmax', kjit, qsintmax, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'qsintveg', kjit, qsintveg, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'humrel',   kjit, humrel,   kjpindex*nvm, indexveg)
+
+          histvar(:)=zero
+          DO jv = 1, nvm
+             DO ji = 1, kjpindex
+                IF ( vegtot(ji) .GT. zero ) THEN
+                   histvar(ji)=histvar(ji)+veget(ji,jv)/vegtot(ji)*MAX((0.1-dss(ji,jv))*mx_eau_eau, zero)
+                ENDIF
+             ENDDO
+          ENDDO
+          CALL histwrite(hist2_id, 'mrsos', kjit, histvar, kjpindex, index)
+
+          histvar(:)=(run_off_tot(:)+drainage(:))/one_day
+          CALL histwrite(hist2_id, 'mrro', kjit, histvar, kjpindex, index)
+
+       ELSE
+          CALL histwrite(hist2_id, 'Snowf', kjit, precip_snow, kjpindex, index)
+          CALL histwrite(hist2_id, 'Rainf', kjit, precip_rain, kjpindex, index)
+          CALL histwrite(hist2_id, 'Qs', kjit, run_off_tot, kjpindex, index)
+          CALL histwrite(hist2_id, 'Qsb', kjit, drainage, kjpindex, index)
+          CALL histwrite(hist2_id, 'Qsm', kjit, tot_melt, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelSoilMoist', kjit, delsoilmoist, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelSWE', kjit, delswe, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelIntercept', kjit, delintercept, kjpindex, index)
+          !
+          CALL histwrite(hist2_id, 'SoilMoist', kjit, tot_watsoil_end, kjpindex, index)
+          CALL histwrite(hist2_id, 'SoilWet', kjit, soilwet, kjpindex, index)
+          !
+          CALL histwrite(hist2_id, 'RootMoist', kjit, tot_watsoil_end, kjpindex, index)
+          CALL histwrite(hist2_id, 'SubSnow', kjit, vevapsno, kjpindex, index)
+          !
+          CALL histwrite(hist2_id, 'SnowDepth', kjit, snowdepth, kjpindex, index)
+          !
+       ENDIF
+    ENDIF
+
+    !
+    IF (long_print) WRITE (numout,*) ' hydrolc_main Done '
+
+  END SUBROUTINE hydrolc_main
+
+  !! Algorithm:
+  !! - dynamic allocation for local array 
+  !! - _restart_ file reading for HYDROLOGIC variables
+  !!
+  SUBROUTINE hydrolc_init(kjit, ldrestart_read, kjpindex, index, rest_id, veget, humrel, vegstress, &
+       & snow, snow_age, snow_nobio, snow_nobio_age, qsintveg)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                         :: kjit               !! Time step number 
+    LOGICAL,INTENT (in)                                :: ldrestart_read     !! Logical for _restart_ file to read
+    INTEGER(i_std), INTENT (in)                         :: kjpindex           !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: index              !! Indeces of the points on the map
+    INTEGER(i_std), INTENT (in)                         :: rest_id            !! _Restart_ file identifier 
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)   :: veget              !! Carte de vegetation
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: humrel             !! Stress hydrique, relative humidity
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out) :: vegstress     !! Veg. moisture stress (only for vegetation growth)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: snow               !! Snow mass [Kg/m^2]
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: snow_age           !! Snow age
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio       !! Snow on ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: snow_nobio_age   !! Snow age on ice, lakes, ...
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)  :: qsintveg           !! Water on vegetation due to interception
+
+    ! local declaration
+    INTEGER(i_std)                                     :: ier
+    INTEGER(i_std)                                     :: ji,jv,ik
+    REAL(r_std), DIMENSION (kjpindex,nvm)               :: zdsp, tmpdss
+
+    REAL(r_std), ALLOCATABLE, DIMENSION (:,:)          :: dsp_g 
+    REAL(r_std), ALLOCATABLE, DIMENSION (:,:)          :: zdsp_g
+    
+    REAL(r_std), DIMENSION(kjpindex)                   :: a_subgrd
+
+    ! initialisation
+    IF (l_first_hydrol) THEN 
+        l_first_hydrol=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_hydrol false . we stop '
+        STOP 'hydrolc_init'
+    ENDIF
+
+    !Config  Key  = HYDROL_OK_HDIFF
+    !Config  Desc = do horizontal diffusion?
+    !Config  Def  = n
+    !Config  Help = If TRUE, then water can diffuse horizontally between
+    !Config         the PFTs' water reservoirs.
+ 
+    ok_hdiff = .FALSE.
+    CALL getin_p('HYDROL_OK_HDIFF',ok_hdiff) 
+
+    ! make dynamic allocation with good dimension
+
+    ! one dimension array allocation with possible restart value
+
+    ALLOCATE (bqsb(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in bqsb allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    bqsb(:,:) = zero
+
+    ALLOCATE (gqsb(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in gqsb allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    gqsb(:,:) = zero
+
+    ALLOCATE (dsg(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in dsg allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    dsg(:,:) = zero
+
+    ALLOCATE (dsp(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in dsp allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    dsp(:,:) = zero
+
+    ! one dimension array allocation 
+
+    ALLOCATE (mean_bqsb(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in mean_bqsb allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    mean_bqsb(:) = zero
+
+    ALLOCATE (mean_gqsb(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in mean_gqsb allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    mean_gqsb(:) = zero
+
+    ALLOCATE (dss(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in dss allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    dss(:,:) = zero
+
+    ALLOCATE (hdry(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in hdry allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    hdry(:) = zero
+
+    ALLOCATE (precisol(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in precisol allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    precisol(:,:) = zero
+
+    ALLOCATE (gdrainage(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in precisol allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    gdrainage(:,:) = zero
+
+    ALLOCATE (subsnowveg(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in subsnowveg allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    subsnowveg(:) = zero
+
+    ALLOCATE (subsnownobio(kjpindex,nnobio),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in subsnownobio allocation. We stop. We need kjpindex*nnobio words = ', &
+          kjpindex*nnobio
+        STOP 'hydrolc_init'
+    END IF
+    subsnownobio(:,:) = zero
+
+    ALLOCATE (snowmelt(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in snowmelt allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    snowmelt(:) = zero
+
+    ALLOCATE (icemelt(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in icemelt allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    icemelt(:) = zero
+
+    ALLOCATE (mx_eau_var(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in mx_eau_var allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    mx_eau_var(:) = zero
+
+    ALLOCATE (ruu_ch(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in ruu_ch allocation. We stop. We need kjpindex words = ',kjpindex
+        STOP 'hydrolc_init'
+    END IF
+    ruu_ch(:) = zero
+
+    ALLOCATE (vegtot(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in vegtot allocation. We stop. We need kjpindex words = ',kjpindex*nvm
+        STOP 'hydrolc_init'
+    END IF
+    vegtot(:) = zero
+
+    ALLOCATE (resdist(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in resdist allocation. We stop. We need kjpindex words = ',kjpindex*nvm
+        STOP 'hydrolc_init'
+    END IF
+    resdist(:,:) = zero
+
+    ALLOCATE (runoff(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in runoff allocation. We stop. We need kjpindex words = ',kjpindex*nvm
+        STOP 'hydrolc_init'
+    END IF
+    runoff(:,:) = zero
+    !
+    !  If we check the water balance we need two more variables
+    !
+    IF ( check_waterbal ) THEN
+
+       ALLOCATE (tot_water_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_water_beg allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (tot_water_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_water_end allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+    ENDIF
+    !
+    !  If we use the almaoutputs we need four more variables
+    !
+    IF ( almaoutput ) THEN
+
+       ALLOCATE (tot_watveg_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watveg_beg allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (tot_watveg_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watveg_end allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (tot_watsoil_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watsoil_beg allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (tot_watsoil_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in tot_watsoil_end allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (delsoilmoist(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in delsoilmoist allocation. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (delintercept(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in delintercept. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (delswe(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in delswe. We stop. We need kjpindex words = ',kjpindex
+          STOP 'hydrolc_init'
+       ENDIF
+
+       ALLOCATE (snow_beg(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in snow_beg allocation. We stop. We need kjpindex words =',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+       ALLOCATE (snow_end(kjpindex),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in snow_end allocation. We stop. We need kjpindex words =',kjpindex
+          STOP 'hydrolc_init'
+       END IF
+
+    ENDIF
+
+    ! open restart input file done by sechiba_init
+    ! and read data from restart input file for HYDROLOGIC process
+
+    IF (ldrestart_read) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to read a restart file for HYDROLOGIC variables'
+
+        var_name= 'snow'        
+        CALL ioconf_setatt('UNITS', 'kg/m^2')
+        CALL ioconf_setatt('LONG_NAME','Snow mass')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1  , 1, kjit, .TRUE., snow, "gather", nbp_glo, index_g)
+!!$        ! correction for old restart
+!!$        DO ik=1, kjpindex
+!!$           if(snow(ik).gt.maxmass_glacier) snow(ik)=maxmass_glacier
+!!$        ENDDO
+        !
+        var_name= 'snow_age'
+        CALL ioconf_setatt('UNITS', 'd')
+        CALL ioconf_setatt('LONG_NAME','Snow age')
+        CALL restget_p (rest_id, var_name, nbp_glo, 1  , 1, kjit, .TRUE., snow_age, "gather", nbp_glo, index_g)
+        !
+        var_name= 'snow_nobio'
+        CALL ioconf_setatt('UNITS', 'kg/m^2')
+        CALL ioconf_setatt('LONG_NAME','Snow on other surface types')
+        CALL restget_p (rest_id, var_name, nbp_glo, nnobio  , 1, kjit, .TRUE., snow_nobio, "gather", nbp_glo, index_g)
+!!$        ! correction for old restart
+!!$        DO ik=1, kjpindex
+!!$           if(snow_nobio(ik,iice).gt.maxmass_glacier) snow_nobio(ik,iice)=maxmass_glacier
+!!$        ENDDO
+        !
+        var_name= 'snow_nobio_age'
+        CALL ioconf_setatt('UNITS', 'd')
+        CALL ioconf_setatt('LONG_NAME','Snow age on other surface types')
+        CALL restget_p (rest_id, var_name, nbp_glo, nnobio  , 1, kjit, .TRUE., snow_nobio_age, "gather", nbp_glo, index_g)
+        !
+        var_name= 'humrel'
+        CALL ioconf_setatt('UNITS', '-')
+        CALL ioconf_setatt('LONG_NAME','Soil moisture stress')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., humrel, "gather", nbp_glo, index_g)
+        !
+        var_name= 'vegstress'
+        CALL ioconf_setatt('UNITS', '-')
+        CALL ioconf_setatt('LONG_NAME','Vegetation growth moisture stress')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., vegstress, "gather", nbp_glo, index_g)
+        !
+        var_name= 'bqsb'
+        CALL ioconf_setatt('UNITS', 'kg/m^2')
+        CALL ioconf_setatt('LONG_NAME','Deep soil moisture')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm , 1, kjit, .TRUE., bqsb, "gather", nbp_glo, index_g)
+        !
+        var_name= 'gqsb'
+        CALL ioconf_setatt('UNITS', 'kg/m^2')
+        CALL ioconf_setatt('LONG_NAME','Surface soil moisture')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm , 1, kjit, .TRUE., gqsb, "gather", nbp_glo, index_g)
+        !
+        var_name= 'dsg'
+        CALL ioconf_setatt('UNITS', 'm')
+        CALL ioconf_setatt('LONG_NAME','Depth of upper reservoir')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm  , 1, kjit, .TRUE., dsg, "gather", nbp_glo, index_g)
+        !
+        var_name= 'dsp'
+        CALL ioconf_setatt('UNITS', 'm')
+        CALL ioconf_setatt('LONG_NAME','Depth to lower reservoir')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm  , 1, kjit, .TRUE., dsp, "gather", nbp_glo, index_g)
+        !
+        var_name= 'dss'
+        CALL ioconf_setatt('UNITS', 'm')
+        CALL ioconf_setatt('LONG_NAME','Hauteur au dessus du reservoir de surface')
+        IF ( ok_var(var_name) ) THEN
+           CALL restget_p (rest_id, var_name, nbp_glo, nvm  , 1, kjit, .TRUE., dss, "gather", nbp_glo, index_g)
+        ENDIF
+        !
+        var_name= 'hdry'
+        CALL ioconf_setatt('UNITS', 'm')
+        CALL ioconf_setatt('LONG_NAME','Dry soil heigth in meters')
+        IF ( ok_var(var_name) ) THEN
+           CALL restget_p (rest_id, var_name, nbp_glo, 1 , 1, kjit, .TRUE., hdry, "gather", nbp_glo, index_g)
+        ENDIF
+        !
+        var_name= 'qsintveg'
+        CALL ioconf_setatt('UNITS', 'kg/m^2')
+        CALL ioconf_setatt('LONG_NAME','Intercepted moisture')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., qsintveg, "gather", nbp_glo, index_g)
+        !
+        var_name= 'resdist'
+        CALL ioconf_setatt('UNITS', '-')
+        CALL ioconf_setatt('LONG_NAME','Distribution of reservoirs')
+        CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., resdist, "gather", nbp_glo, index_g)
+        !
+        ! get restart values if non were found in the restart file
+        !
+        !Config Key  = HYDROL_SNOW
+        !Config Desc = Initial snow mass if not found in restart
+        !Config Def  = 0.0
+        !Config Help = The initial value of snow mass if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (snow, val_exp, 'HYDROL_SNOW', zero)
+        !
+        !Config Key  = HYDROL_SNOWAGE
+        !Config Desc = Initial snow age if not found in restart
+        !Config Def  = 0.0
+        !Config Help = The initial value of snow age if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (snow_age, val_exp, 'HYDROL_SNOWAGE', zero)
+        !
+        !Config Key  = HYDROL_SNOW_NOBIO
+        !Config Desc = Initial snow amount on ice, lakes, etc. if not found in restart
+        !Config Def  = 0.0
+        !Config Help = The initial value of snow if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (snow_nobio, val_exp, 'HYDROL_SNOW_NOBIO', zero)
+        !
+        !Config Key  = HYDROL_SNOW_NOBIO_AGE
+        !Config Desc = Initial snow age on ice, lakes, etc. if not found in restart
+        !Config Def  = 0.0
+        !Config Help = The initial value of snow age if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (snow_nobio_age, val_exp, 'HYDROL_SNOW_NOBIO_AGE', zero)
+        !
+        !Config Key  = HYDROL_HUMR
+        !Config Desc = Initial soil moisture stress if not found in restart
+        !Config Def  = 1.0
+        !Config Help = The initial value of soil moisture stress if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (humrel, val_exp,'HYDROL_HUMR', un)
+        CALL setvar_p (vegstress, val_exp,'HYDROL_HUMR', un)
+        !
+        !Config Key  = HYDROL_BQSB
+        !Config Desc = Initial restart deep soil moisture if not found in restart
+        !Config Def  = DEF
+        !Config Help = The initial value of deep soil moisture if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file. Default behaviour is a saturated soil.
+        !
+        CALL setvar_p (bqsb, val_exp, 'HYDROL_BQSB', mx_eau_eau*dpu_cste)
+        !
+        !Config Key  = HYDROL_GQSB
+        !Config Desc = Initial upper soil moisture if not found in restart
+        !Config Def  = 0.0
+        !Config Help = The initial value of upper soil moisture if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (gqsb, val_exp, 'HYDROL_GQSB', zero)
+        !
+        !Config Key  = HYDROL_DSG
+        !Config Desc = Initial upper reservoir depth if not found in restart
+        !Config Def  = 0.0
+        !Config Help = The initial value of upper reservoir depth if its value is not found
+        !Config        in the restart file. This should only be used if the model is 
+        !Config        started without a restart file.
+        !
+        CALL setvar_p (dsg, val_exp, 'HYDROL_DSG', zero)
+
+        ! set inital value for dsp if needed
+        !
+        !Config Key  = HYDROL_DSP
+        !Config Desc = Initial dry soil above upper reservoir if not found in restart
+        !Config Def  = DEF
+        !Config Help = The initial value of dry soil above upper reservoir if its value 
+        !Config        is not found in the restart file. This should only be used if
+        !Config        the model is started without a restart file. The default behaviour
+        !Config        is to compute it from the variables above. Should be OK most of 
+        !Config        the time.
+        !
+        zdsp(:,:) = dpu_cste - bqsb(:,:) / mx_eau_eau
+        dsp(1,1) = val_exp
+        call getin_p('HYDROL_DSP', dsp(1,1))
+        IF (dsp(1,1) == val_exp) THEN
+           dsp(:,:) = zdsp(:,:)
+        ELSE
+           IF (is_root_prc) &
+                ALLOCATE(zdsp_g(nbp_glo,nvm),dsp_g(nbp_glo,nvm))
+           CALL gather(zdsp,zdsp_g)
+           IF (is_root_prc) &
+                CALL setvar (dsp_g, val_exp, 'HYDROL_DSP', zdsp_g)
+           CALL scatter(dsp_g,dsp)
+           IF (is_root_prc) &
+                DEALLOCATE(zdsp_g, dsp_g)
+        ENDIF
+        !
+        !Config Key  = HYDROL_QSV
+        !Config Desc = Initial water on canopy if not found in restart
+        !Config Def  = 0.0
+        !Config Help = The initial value of moisture on canopy if its value 
+        !Config        is not found in the restart file. This should only be used if
+        !Config        the model is started without a restart file. 
+        !
+        CALL setvar_p (qsintveg, val_exp, 'HYDROL_QSV', zero)
+        !
+        tmpdss = dsg - gqsb / mx_eau_eau
+        IF ( ok_var("dss") ) THEN
+           CALL setvar_p (dss, val_exp, 'NO_KEYWORD', tmpdss)
+        ELSE
+           dss(:,:)=tmpdss(:,:)
+        ENDIF
+
+        IF ( ok_var("hdry") ) THEN
+           IF (MINVAL(hdry) .EQ. MAXVAL(hdry) .AND. MAXVAL(hdry) .EQ. val_exp) THEN
+              a_subgrd(:) = zero
+              DO ji=1,kjpindex
+                 IF ( gqsb(ji,1)+bqsb(ji,1) .GT. zero ) THEN
+                    !
+                    IF (.NOT. (dsg(ji,1).EQ. zero .OR. gqsb(ji,1).EQ.zero)) THEN
+                       ! Ajouts Nathalie - Fred - le 28 Mars 2006
+                       a_subgrd(ji)=MIN(MAX(dsg(ji,1)-dss(ji,1),zero)/dsg_min,un)
+                       !
+                    ENDIF
+                 ENDIF
+                 !
+              ENDDO
+              ! Correction Nathalie - le 28 Mars 2006 - re-ecriture drysoil_frac/hdry - Fred Hourdin
+              ! revu 22 novembre 2007
+              hdry(:) = a_subgrd(:)*dss(:,1) + (1.-a_subgrd(:))*dsp(:,1)
+           ENDIF
+        ELSE
+           a_subgrd(:) = zero
+           DO ji=1,kjpindex
+              IF ( gqsb(ji,1)+bqsb(ji,1) .GT. zero ) THEN
+                 !
+                 IF (.NOT. (dsg(ji,1).EQ. zero .OR. gqsb(ji,1).EQ.zero)) THEN
+                    ! Ajouts Nathalie - Fred - le 28 Mars 2006
+                    a_subgrd(ji)=MIN(MAX(dsg(ji,1)-dss(ji,1),zero)/dsg_min,un)
+                    !
+                 ENDIF
+              ENDIF
+              !
+           ENDDO
+           
+           ! Correction Nathalie - le 28 Mars 2006 - re-ecriture drysoil_frac/hdry - Fred Hourdin
+           ! revu 22 novembre 2007
+           hdry(:) = a_subgrd(:)*dss(:,1) + (un-a_subgrd(:))*dsp(:,1)
+        ENDIF
+        !
+        ! There is no need to configure the initialisation of resdist. If not available it is the vegetation map
+        !
+        IF ( MINVAL(resdist) .EQ.  MAXVAL(resdist) .AND. MINVAL(resdist) .EQ. val_exp) THEN
+            resdist = veget
+        ENDIF
+        !
+        !  Remember that it is only frac_nobio + SUM(veget(,:)) that is equal to 1. Thus we need vegtot
+        !
+        DO ji = 1, kjpindex
+           vegtot(ji) = SUM(veget(ji,:))
+        ENDDO
+        !
+    ENDIF
+
+    !
+    ! Where vegetation fraction is zero, set water to that of bare soil.
+    ! This does not create any additional water.
+    !
+    DO jv = 2, nvm
+      DO ji = 1, kjpindex
+        IF ( veget(ji,jv) .LT. EPSILON(un) ) THEN
+          gqsb(ji,jv) = gqsb(ji,1)
+          bqsb(ji,jv) = bqsb(ji,1)
+          dsg(ji,jv) = dsg(ji,1)
+          dss(ji,jv) = dss(ji,1)
+          dsp(ji,jv) = dsp(ji,1)
+        ENDIF
+      ENDDO
+    ENDDO
+    !
+    DO ik=1, kjpindex
+       if(snow(ik).gt.maxmass_glacier) then
+          WRITE(numout,*)' il faut diminuer le stock de neige car snow > maxmass_glacier dans restart'
+	  snow(ik)=maxmass_glacier
+       endif
+       if(snow_nobio(ik,iice).gt.maxmass_glacier) then
+          WRITE(numout,*)' il faut diminuer le stock de neige car snow_nobio > maxmass_glacier dans restart'
+          snow_nobio(ik,iice)=maxmass_glacier
+       endif
+    ENDDO
+    !
+    IF (long_print) WRITE (numout,*) ' hydrolc_init done '
+    !
+  END SUBROUTINE hydrolc_init
+  !
+  !-------------------------------------
+  !
+  SUBROUTINE hydrolc_clear()
+ 
+    l_first_hydrol=.TRUE.
+
+    IF (ALLOCATED (bqsb)) DEALLOCATE (bqsb)
+    IF (ALLOCATED  (gqsb)) DEALLOCATE (gqsb)
+    IF (ALLOCATED  (dsg))  DEALLOCATE (dsg)
+    IF (ALLOCATED  (dsp))  DEALLOCATE (dsp)
+    IF (ALLOCATED  (mean_bqsb))  DEALLOCATE (mean_bqsb)
+    IF (ALLOCATED  (mean_gqsb)) DEALLOCATE (mean_gqsb)
+    IF (ALLOCATED  (dss)) DEALLOCATE (dss)
+    IF (ALLOCATED  (hdry)) DEALLOCATE (hdry)
+    IF (ALLOCATED  (precisol)) DEALLOCATE (precisol)
+    IF (ALLOCATED  (gdrainage)) DEALLOCATE (gdrainage)
+    IF (ALLOCATED  (subsnowveg)) DEALLOCATE (subsnowveg)
+    IF (ALLOCATED  (subsnownobio)) DEALLOCATE (subsnownobio)
+    IF (ALLOCATED  (snowmelt)) DEALLOCATE (snowmelt)
+    IF (ALLOCATED  (icemelt)) DEALLOCATE (icemelt)
+    IF (ALLOCATED  (mx_eau_var)) DEALLOCATE (mx_eau_var)
+    IF (ALLOCATED  (ruu_ch)) DEALLOCATE (ruu_ch)
+    IF (ALLOCATED  (vegtot)) DEALLOCATE (vegtot)
+    IF (ALLOCATED  (resdist)) DEALLOCATE (resdist)
+    IF (ALLOCATED  (runoff)) DEALLOCATE (runoff)
+    IF (ALLOCATED  (tot_water_beg)) DEALLOCATE (tot_water_beg)
+    IF (ALLOCATED  (tot_water_end)) DEALLOCATE (tot_water_end)
+    IF (ALLOCATED  (tot_watveg_beg)) DEALLOCATE (tot_watveg_beg)
+    IF (ALLOCATED  (tot_watveg_end)) DEALLOCATE (tot_watveg_end)
+    IF (ALLOCATED  (tot_watsoil_beg)) DEALLOCATE (tot_watsoil_beg)
+    IF (ALLOCATED  (tot_watsoil_end)) DEALLOCATE (tot_watsoil_end)
+    IF (ALLOCATED  (delsoilmoist)) DEALLOCATE (delsoilmoist)
+    IF (ALLOCATED  (delintercept)) DEALLOCATE (delintercept)
+    IF (ALLOCATED  (snow_beg)) DEALLOCATE (snow_beg)
+    IF (ALLOCATED  (snow_end)) DEALLOCATE (snow_end)
+    IF (ALLOCATED  (delswe)) DEALLOCATE (delswe)
+    !
+ END SUBROUTINE hydrolc_clear
+
+  !! This routine initializes HYDROLOGIC variables 
+  !! - mx_eau_var
+  !! - ruu_ch
+  !!
+  SUBROUTINE hydrolc_var_init (kjpindex, veget, veget_max, rsol, drysoil_frac, mx_eau_var, ruu_ch, shumdiag, litterhumdiag)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                         :: kjpindex      !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget         !! Fraction of vegetation type 
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget_max     !! Max. fraction of vegetation type 
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: rsol          !! Resistance to bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: drysoil_frac  !! Fraction of visible dry soil
+    !! Profondeur du reservoir contenant le maximum d'eau  
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: mx_eau_var    !!
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: ruu_ch        !! Quantite d'eau maximum
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out):: shumdiag      !! relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)     :: litterhumdiag !! litter humidity
+    ! local declaration
+    INTEGER(i_std)                                    :: ji,jv, jd
+    REAL(r_std), DIMENSION(kjpindex)                   :: mean_dsg
+    REAL(r_std)                                        :: gtr, btr
+    REAL(r_std), DIMENSION(nbdl+1)                     :: tmp_dl
+    !
+    ! initialisation
+    tmp_dl(1) = 0
+    tmp_dl(2:nbdl+1) = diaglev(1:nbdl)
+    !
+    mx_eau_var(:) = zero
+    !
+    DO ji = 1,kjpindex
+      DO jv = 1,nvm
+         mx_eau_var(ji) = mx_eau_var(ji) + veget(ji,jv)*wmax_veg(jv)*dpu_cste
+      END DO
+      IF (vegtot(ji) .GT. zero) THEN
+         mx_eau_var(ji) = mx_eau_var(ji)/vegtot(ji)
+      ELSE
+         mx_eau_var(ji) = mx_eau_eau*dpu_cste
+      ENDIF
+      ruu_ch(ji) = mx_eau_var(ji) / dpu_cste
+    END DO
+    !
+    !
+    ! could be done with SUM instruction but this kills vectorization
+    mean_bqsb(:) = zero
+    mean_gqsb(:) = zero
+    mean_dsg(:) = zero
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        mean_bqsb(ji) = mean_bqsb(ji) + resdist(ji,jv)*bqsb(ji,jv)
+        mean_gqsb(ji) = mean_gqsb(ji) + resdist(ji,jv)*gqsb(ji,jv)
+        mean_dsg(ji) = mean_dsg(ji) + resdist(ji,jv)*dsg(ji,jv)
+      ENDDO
+    ENDDO
+    mean_dsg(:) = MAX( mean_dsg(:), mean_gqsb(:)/ruu_ch(:) )
+
+    DO ji = 1, kjpindex
+      IF (vegtot(ji) .GT. zero) THEN
+        mean_bqsb(ji) = mean_bqsb(ji)/vegtot(ji)
+        mean_gqsb(ji) = mean_gqsb(ji)/vegtot(ji)
+        mean_dsg(ji) = mean_dsg(ji)/vegtot(ji)
+      ENDIF
+    ENDDO
+
+    DO jd = 1,nbdl
+       !
+       DO ji = 1,kjpindex
+!!$       !
+!!$       DO jd = 1,nbdl
+          IF ( tmp_dl(jd+1) .LT. mean_dsg(ji)) THEN
+             shumdiag(ji,jd) = mean_gqsb(ji)/mx_eau_var(ji)
+          ELSE
+             IF ( tmp_dl(jd) .LT. mean_dsg(ji)) THEN
+                gtr = (mean_dsg(ji)-tmp_dl(jd))/(tmp_dl(jd+1)-tmp_dl(jd))
+                btr = 1 - gtr
+                shumdiag(ji,jd) = gtr*mean_gqsb(ji)/mx_eau_var(ji) + &
+                     & btr*mean_bqsb(ji)/mx_eau_var(ji)
+             ELSE
+                shumdiag(ji,jd) = mean_bqsb(ji)/mx_eau_var(ji)
+             ENDIF
+          ENDIF
+          shumdiag(ji,jd) = MAX(MIN(shumdiag(ji,jd), un), zero)
+       ENDDO
+    ENDDO
+
+    ! The fraction of soil which is visibly dry (dry when dss = 0.1 m)
+    drysoil_frac(:) = MIN(MAX(dss(:,1),zero)*10._r_std, un)
+    !
+    ! Compute the resistance to bare soil evaporation
+    !
+    rsol(:) = -un
+    DO ji = 1, kjpindex
+       IF (veget(ji,1) .GE. min_sechiba) THEN
+          !
+          ! Correction Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
+          ! on modifie le rsol pour que la resistance croisse subitement si on s'approche
+          ! du fond. En gros, rsol=hdry*rsol_cste pour hdry < 1m70
+          !rsol(ji) = dss(ji,1) * rsol_cste
+          !rsol(ji) =  ( drysoil_frac(ji) + un/(10.*(dpu_cste - drysoil_frac(ji))+1.e-10)**2 ) * rsol_cste
+          rsol(ji) =  ( hdry(ji) + un/(10.*(dpu_cste - hdry(ji))+1.e-10)**2 ) * rsol_cste
+       ENDIF
+    ENDDO
+
+    !
+    ! litter humidity.
+    !
+
+!!$    DO ji = 1, kjpindex
+!!$      litterhumdiag(ji) = EXP( - dss(ji,1) / hcrit_litter )
+!!$    ENDDO
+    litterhumdiag(:) = EXP( - hdry(:) / hcrit_litter )
+
+    ! special case: it has just been raining a few drops. The upper soil
+    ! reservoir is ridiculously small, but the dry soil height is zero.
+    ! Don't take it into account.
+
+!!$    DO ji = 1, kjpindex
+!!$      IF ( ( dss(ji,1) .LT. min_sechiba ) .AND. &
+!!$            ( mean_dsg(ji) .GT. min_sechiba ) .AND. &
+!!$            ( mean_dsg(ji) .LT. 5.E-4 ) ) THEN
+!!$        litterhumdiag(ji) = zero
+!!$      ENDIF
+!!$    ENDDO
+    WHERE ( ( hdry(:) .LT. min_sechiba ) .AND. &
+            ( mean_dsg(:) .GT. min_sechiba ) .AND. ( mean_dsg(:) .LT. 5.E-4 ) )
+      litterhumdiag(:) = zero
+    ENDWHERE
+
+    !
+    IF (long_print) WRITE (numout,*) ' hydrolc_var_init done '
+
+  END SUBROUTINE hydrolc_var_init
+
+  !! This routine computes snow processes
+  !!
+  SUBROUTINE hydrolc_snow (kjpindex, dtradia, precip_rain, precip_snow , temp_sol_new, soilcap,&
+       & frac_nobio, totfrac_nobio, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age, &
+       & tot_melt, snowdepth)
+
+    ! 
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex      !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia       !! Time step in seconds
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_rain   !! Rainfall
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_snow   !! Snow precipitation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: temp_sol_new  !! New soil temperature
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: soilcap       !! Soil capacity
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(in)     :: frac_nobio    !! Fraction of continental ice, lakes, ...
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: totfrac_nobio !! Total fraction of continental ice+lakes+ ...
+    ! modified fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapnu       !! Bare soil evaporation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: vevapsno      !! Snow evaporation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: snow          !! Snow mass [Kg/m^2]
+    REAL(r_std), DIMENSION (kjpindex), INTENT(inout)         :: snow_age      !! Snow age
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout)  :: snow_nobio    !! Ice water balance
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout)  :: snow_nobio_age!! Snow age on ice, lakes, ...
+    ! output fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: tot_melt      !! Total melt  
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: snowdepth     !! Snow depth 
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                               :: ji, jv
+    REAL(r_std), DIMENSION (kjpindex)             :: d_age  !! Snow age change
+    REAL(r_std), DIMENSION (kjpindex)             :: xx     !! temporary
+    REAL(r_std)                                   :: snowmelt_tmp !! The name says it all !
+    LOGICAL, DIMENSION (kjpindex)                 :: warnings
+    LOGICAL                                       :: any_warning
+    !
+    ! for continental points
+    !
+
+    ! 
+    ! 0. initialisation
+    !
+    DO jv = 1, nnobio
+      DO ji=1,kjpindex
+        subsnownobio(ji,jv) = zero
+      ENDDO
+    ENDDO
+    DO ji=1,kjpindex
+      subsnowveg(ji) = zero
+      snowmelt(ji) = zero
+      icemelt(ji) = zero
+      tot_melt(ji) = zero
+    ENDDO
+    !
+    ! 1. On vegetation
+    !
+!cdir NODEP
+    DO ji=1,kjpindex
+      !
+      ! 1.1. It is snowing
+      !
+      snow(ji) = snow(ji) + (un - totfrac_nobio(ji))*precip_snow(ji)
+    ENDDO
+    !
+    DO ji=1,kjpindex
+      !
+      ! 1.2. Sublimation - separate between vegetated and no-veget fractions
+      !      Care has to be taken as we might have sublimation from the
+      !      the frac_nobio while there is no snow on the rest of the grid.
+      !
+      IF ( snow(ji) > snowcri ) THEN
+         subsnownobio(ji,iice) = frac_nobio(ji,iice)*vevapsno(ji)
+         subsnowveg(ji) = vevapsno(ji) - subsnownobio(ji,iice)
+      ELSE
+         ! Correction Nathalie - Juillet 2006.
+         ! On doit d'abord tester s'il existe un frac_nobio!
+         ! Pour le moment je ne regarde que le iice
+         IF ( frac_nobio(ji,iice) .GT. min_sechiba) THEN
+            subsnownobio(ji,iice) = vevapsno(ji)
+            subsnowveg(ji) = zero
+         ELSE 
+            subsnownobio(ji,iice) = zero
+            subsnowveg(ji) = vevapsno(ji)
+         ENDIF
+      ENDIF
+    ENDDO
+    !
+    warnings(:) = .FALSE.
+    any_warning = .FALSE.
+!cdir NODEP
+    DO ji=1,kjpindex
+      !
+      ! 1.2.1 Check that sublimation on the vegetated fraction is possible.
+      !
+      IF (subsnowveg(ji) .GT. snow(ji)) THEN 
+         ! What could not be sublimated goes into bare soil evaporation
+         ! Nathalie - Juillet 2006 - il faut avant tout tester s'il existe du
+         ! frac_nobio sur ce pixel pour eviter de puiser dans le sol!         
+         IF ( frac_nobio(ji,iice) .GT. min_sechiba) THEN
+            subsnownobio(ji,iice) = subsnownobio(ji,iice) + (subsnowveg(ji) - snow(ji))
+         ELSE  
+            vevapnu(ji) = vevapnu(ji) + (subsnowveg(ji) - snow(ji))
+            warnings(ji) = .TRUE.
+            any_warning = .TRUE.
+         ENDIF
+         ! Sublimation is thus limited to what is available
+         subsnowveg(ji) = snow(ji)
+         snow(ji) = zero
+         vevapsno(ji) = subsnowveg(ji) + subsnownobio(ji,iice)
+      ELSE 
+         snow(ji) = snow(ji) - subsnowveg(ji)
+      ENDIF
+    ENDDO
+    IF ( any_warning ) THEN
+       WRITE(numout,*)' ATTENTION on prend de l eau au sol nu sur au moins un point car evapsno est trop fort!'
+!!$       DO ji=1,kjpindex
+!!$          IF ( warnings(ji) ) THEN
+!!$             WRITE(numout,*)' ATTENTION on prend de l eau au sol nu car evapsno est trop fort!'
+!!$             WRITE(numout,*)' ',ji,'   vevapnu (en mm/jour) = ',vevapnu(ji)*one_day/dtradia
+!!$          ENDIF
+!!$       ENDDO
+    ENDIF
+    !
+    warnings(:) = .FALSE.
+    any_warning = .FALSE.
+!cdir NODEP
+    DO ji=1,kjpindex
+      !
+      ! 1.3. snow melt only if temperature positive
+      !
+      IF (temp_sol_new(ji).GT.tp_00) THEN 
+         !
+         IF (snow(ji).GT.sneige) THEN 
+            !
+            snowmelt(ji) = (un - frac_nobio(ji,iice))*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0 
+            !
+            ! 1.3.1.1 enough snow for melting or not
+            !
+            IF (snowmelt(ji).LT.snow(ji)) THEN 
+               snow(ji) = snow(ji) - snowmelt(ji)
+            ELSE 
+               snowmelt(ji) = snow(ji)
+               snow(ji) = zero
+            END IF
+            !
+         ELSEIF (snow(ji).GE.zero) THEN 
+            !
+            ! 1.3.2 not enough snow
+            !
+            snowmelt(ji) = snow(ji)
+            snow(ji) = zero
+         ELSE 
+            !
+            ! 1.3.3 negative snow - now snow melt
+            !
+            snow(ji) = zero
+            snowmelt(ji) = zero
+            warnings(ji) = .TRUE.
+            any_warning = .TRUE.
+            !
+         END IF
+
+      ENDIF
+    ENDDO
+    IF ( any_warning ) THEN
+       DO ji=1,kjpindex
+          IF ( warnings(ji) ) THEN
+             WRITE(numout,*) 'hydrolc_snow: WARNING! snow was negative and was reset to zero for point ',ji,'. '
+          ENDIF
+       ENDDO
+    ENDIF
+    !
+    DO ji=1,kjpindex
+      !
+      ! 1.4. Ice melt only if there is more than a given mass : maxmass_glacier,
+      !      i.e. only weight melts glaciers !
+      ! Ajouts Edouard Davin / Nathalie de Noblet add extra to melting
+      !
+      IF ( snow(ji) .GT. maxmass_glacier ) THEN
+         snowmelt(ji) = snowmelt(ji) + (snow(ji) - maxmass_glacier)
+         snow(ji) = maxmass_glacier
+      ENDIF
+      !
+    END DO
+    !
+    ! 2. On Land ice
+    !
+    DO ji=1,kjpindex
+      !
+      ! 2.1. It is snowing
+      !
+      snow_nobio(ji,iice) = snow_nobio(ji,iice) + frac_nobio(ji,iice)*precip_snow(ji) + &
+           & frac_nobio(ji,iice)*precip_rain(ji)
+      !
+      ! 2.2. Sublimation - was calculated before it can give us negative snow_nobio but that is OK
+      !      Once it goes below a certain values (-maxmass_glacier for instance) we should kill
+      !      the frac_nobio(ji,iice) !
+      !
+      snow_nobio(ji,iice) = snow_nobio(ji,iice) - subsnownobio(ji,iice)
+      !
+      ! 2.3. snow melt only for continental ice fraction
+      !
+      snowmelt_tmp = zero
+      IF (temp_sol_new(ji) .GT. tp_00) THEN 
+         !
+         ! 2.3.1 If there is snow on the ice-fraction it can melt 
+         !
+         snowmelt_tmp = frac_nobio(ji,iice)*(temp_sol_new(ji) - tp_00) * soilcap(ji) / chalfu0
+         !
+         IF ( snowmelt_tmp .GT. snow_nobio(ji,iice) ) THEN
+             snowmelt_tmp = MAX( zero, snow_nobio(ji,iice))
+         ENDIF
+         snowmelt(ji) = snowmelt(ji) + snowmelt_tmp
+         snow_nobio(ji,iice) = snow_nobio(ji,iice) - snowmelt_tmp
+         !
+      ENDIF
+      !
+      ! 2.4 Ice melt only if there is more than a given mass : maxmass_glacier, 
+      !      i.e. only weight melts glaciers !
+      !
+      IF ( snow_nobio(ji,iice) .GT. maxmass_glacier ) THEN
+         icemelt(ji) = snow_nobio(ji,iice) - maxmass_glacier
+         snow_nobio(ji,iice) = maxmass_glacier
+      ENDIF
+      !
+    END DO
+
+    !
+    ! 3. On other surface types - not done yet
+    !
+    IF ( nnobio .GT. 1 ) THEN
+      WRITE(numout,*) 'WE HAVE',nnobio-1,' SURFACE TYPES I DO NOT KNOW'
+      CALL ipslerr (3,'hydrolc_snow', '', &
+ &         'CANNOT TREAT SNOW ON THESE SURFACE TYPES', '')
+    ENDIF
+
+    !
+    ! 4. computes total melt (snow and ice)
+    !
+
+    DO ji = 1, kjpindex
+      tot_melt(ji) = icemelt(ji) + snowmelt(ji)
+    ENDDO
+
+    ! 
+    ! 5. computes snow age on veg and ice (for albedo)
+    !
+    DO ji = 1, kjpindex
+      !
+      ! 5.1 Snow age on vegetation
+      !
+      IF (snow(ji) .LE. zero) THEN
+        snow_age(ji) = zero
+      ELSE
+        snow_age(ji) =(snow_age(ji) + (un - snow_age(ji)/max_snow_age) * dtradia/one_day) &
+          & * EXP(-precip_snow(ji) / snow_trans)
+      ENDIF
+      !
+      ! 5.2 Snow age on ice
+      !
+      ! age of snow on ice: a little bit different because in cold regions, we really
+      ! cannot negect the effect of cold temperatures on snow metamorphism any more.
+      !
+      IF (snow_nobio(ji,iice) .LE. zero) THEN 
+        snow_nobio_age(ji,iice) = zero
+      ELSE
+      !
+        d_age(ji) = ( snow_nobio_age(ji,iice) + &
+                    &  (un - snow_nobio_age(ji,iice)/max_snow_age) * dtradia/one_day ) * &
+                    &  EXP(-precip_snow(ji) / snow_trans) - snow_nobio_age(ji,iice)
+        IF (d_age(ji) .GT. zero ) THEN
+          xx(ji) = MAX( tp_00 - temp_sol_new(ji), zero )
+          xx(ji) = ( xx(ji) / 7._r_std ) ** 4._r_std
+          d_age(ji) = d_age(ji) / (un+xx(ji))
+        ENDIF
+        snow_nobio_age(ji,iice) = MAX( snow_nobio_age(ji,iice) + d_age(ji), zero )
+      !
+      ENDIF
+
+    ENDDO
+
+    !
+    ! 6.0 Diagnose the depth of the snow layer
+    !
+
+    DO ji = 1, kjpindex
+      snowdepth(ji) = snow(ji) /sn_dens
+    ENDDO
+
+    IF (long_print) WRITE (numout,*) ' hydrolc_snow done '
+
+  END SUBROUTINE hydrolc_snow
+
+  !! This routine computes canopy processes
+  !!
+  SUBROUTINE hydrolc_canop (kjpindex, precip_rain, vevapwet, veget, qsintmax, qsintveg, precisol)
+
+    ! 
+    ! interface description
+    !
+    INTEGER(i_std), INTENT(in)                               :: kjpindex    !! Domain size
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: precip_rain !! Rain precipitation
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: vevapwet    !! Interception loss
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: veget       !! Fraction of vegetation type 
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: qsintmax    !! Maximum water on vegetation for interception
+    ! modified fields
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: qsintveg    !! Water on vegetation due to interception
+    ! output fields
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)           :: precisol    !! Eau tombee sur le sol
+
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                :: ji, jv
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: zqsintvegnew
+    LOGICAL, SAVE                                  :: firstcall=.TRUE.
+    REAL(r_std), SAVE, DIMENSION(nvm)              :: throughfall_by_pft
+
+    IF ( firstcall ) THEN
+       !Config  Key  = PERCENT_THROUGHFALL_PFT
+       !Config  Desc = Percent by PFT of precip that is not intercepted by the canopy
+       !Config  Def  = 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30. 30.
+       !Config  Help = During one rainfall event, PERCENT_THROUGHFALL_PFT% of the incident rainfall
+       !Config         will get directly to the ground without being intercepted, for each PFT.
+       
+       throughfall_by_pft = (/ 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30., 30. /)
+       CALL getin_p('PERCENT_THROUGHFALL_PFT',throughfall_by_pft)
+       throughfall_by_pft = throughfall_by_pft / 100.
+
+       firstcall=.FALSE.
+    ENDIF
+
+    ! calcul de qsintmax a prevoir a chaque pas de temps
+    ! dans ini_sechiba
+    ! boucle sur les points continentaux
+    ! calcul de qsintveg au pas de temps suivant
+    ! par ajout du flux interception loss
+    ! calcule par enerbil en fonction
+    ! des calculs faits dans diffuco
+    ! calcul de ce qui tombe sur le sol
+    ! avec accumulation dans precisol
+    ! essayer d'harmoniser le traitement du sol nu
+    ! avec celui des differents types de vegetation
+    ! fait si on impose qsintmax ( ,1) = 0.0
+    !
+    ! loop for continental subdomain
+    !
+
+    !
+    ! 1. evaporation off the continents
+    !
+    ! 1.1 The interception loss is take off the canopy. 
+
+    DO jv=1,nvm
+      qsintveg(:,jv) = qsintveg(:,jv) - vevapwet(:,jv)
+    END DO
+
+    ! 1.2 It is raining : precip_rain is shared for each vegetation
+    ! type
+    !     sum (veget (1,nvm)) must be egal to 1-totfrac_nobio.
+    !     iniveget computes veget each day
+    !
+    DO jv=1,nvm
+      ! Correction Nathalie - Juin 2006 - une partie de la pluie arrivera toujours sur le sol
+      ! sorte de throughfall supplementaire
+      !qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * precip_rain(:)
+      qsintveg(:,jv) = qsintveg(:,jv) + veget(:,jv) * ((1-throughfall_by_pft(jv))*precip_rain(:))
+    END DO
+
+    !
+    ! 1.3 Limits the effect and sum what receives soil
+    !
+    precisol(:,:) = zero
+    DO jv=1,nvm
+      DO ji = 1, kjpindex
+        zqsintvegnew(ji,jv) = MIN (qsintveg(ji,jv),qsintmax(ji,jv)) 
+        ! correction throughfall Nathalie - Juin 2006
+        !precisol(ji,jv) = qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
+        precisol(ji,jv) = (veget(ji,jv)*throughfall_by_pft(jv)*precip_rain(ji)) + qsintveg(ji,jv ) - zqsintvegnew (ji,jv)
+      ENDDO
+    ENDDO
+    !
+    ! 1.4 swap qsintveg to the new value
+    !
+
+    DO jv=1,nvm
+      qsintveg(:,jv) = zqsintvegnew (:,jv)
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' hydrolc_canop done '
+
+  END SUBROUTINE hydrolc_canop
+  !!
+  !!
+  !!
+  SUBROUTINE hydrolc_vegupd(kjpindex, veget, ruu_ch, qsintveg, gqsb, bqsb, dsg, dss, dsp, resdist)
+    !
+    !
+    !   The vegetation cover has changed and we need to adapt the reservoir distribution.
+    !   You may note that this occurs after evaporation and so on have been computed. It is 
+    !   not a problem as a new vegetation fraction will start with humrel=0 and thus will have no
+    !   evaporation. If this is not the case it should have been caught above.
+    !
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex 
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in)       :: veget            !! New vegetation map
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: ruu_ch           !! Quantite d'eau maximum
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout)  :: qsintveg           !! Water on vegetation due to interception
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: gqsb             !! Hauteur d'eau dans le reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: bqsb             !! Hauteur d'eau dans le reservoir profond
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dsg              !! Hauteur du reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dss              !! Hauteur au dessus du reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dsp              !! Hauteur au dessus du reservoir profond 
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(inout)    :: resdist          !! Old vegetation map
+    !
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                :: ji,jv
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm)           :: qsintveg2                  !! Water on vegetation due to interception over old veget
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: bdq, gdq, qsdq
+    REAL(r_std), DIMENSION (kjpindex,nvm)          :: vmr                        !! variation of veget
+    REAL(r_std), DIMENSION(kjpindex)               :: gtr, btr, vtr, qstr, fra
+    REAL(r_std), DIMENSION(kjpindex) :: vegchtot
+    REAL(r_std), PARAMETER                         :: EPS1 = EPSILON(un)
+    !
+    !
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( ABS(veget(ji,jv)-resdist(ji,jv)) .GT. EPS1 ) THEN
+          vmr(ji,jv) = veget(ji,jv)-resdist(ji,jv)
+        ELSE
+          vmr(ji,jv) = zero
+        ENDIF
+    !
+        IF (resdist(ji,jv) .GT. zero) THEN
+         qsintveg2(ji,jv) = qsintveg(ji,jv)/resdist(ji,jv)
+        ELSE
+         qsintveg2(ji,jv) = zero
+        ENDIF   
+      ENDDO
+    ENDDO
+    !
+    vegchtot(:) = zero
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        vegchtot(ji) = vegchtot(ji) + ABS( vmr(ji,jv) )
+      ENDDO
+    ENDDO
+    !
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( vegchtot(ji) .GT. zero ) THEN
+          gdq(ji,jv) = ABS(vmr(ji,jv)) * gqsb(ji,jv)
+          bdq(ji,jv) = ABS(vmr(ji,jv)) * bqsb(ji,jv)
+          qsdq(ji,jv) = ABS(vmr(ji,jv)) * qsintveg2(ji,jv)
+        ENDIF
+      ENDDO
+    ENDDO
+    !
+    ! calculate water mass that we have to redistribute
+    !
+    gtr(:) = zero
+    btr(:) = zero
+    qstr(:) = zero
+    vtr(:) = zero
+    !
+    !
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( ( vegchtot(ji) .GT. zero ) .AND. ( vmr(ji,jv) .LT. zero ) ) THEN
+          gtr(ji) = gtr(ji) + gdq(ji,jv)
+          btr(ji) = btr(ji) + bdq(ji,jv)
+          qstr(ji) = qstr(ji) + qsdq(ji,jv) 
+          vtr(ji) = vtr(ji) - vmr(ji,jv)
+        ENDIF
+      ENDDO
+    ENDDO
+    !
+    ! put it into reservoir of plant whose surface area has grown
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( vegchtot(ji) .GT. zero .AND. ABS(vtr(ji)) .GT. EPS1) THEN
+            fra(ji) = vmr(ji,jv) / vtr(ji)
+             IF ( vmr(ji,jv) .GT. zero)  THEN
+              IF (veget(ji,jv) .GT. zero) THEN
+               gqsb(ji,jv) = (resdist(ji,jv)*gqsb(ji,jv) + fra(ji)*gtr(ji))/veget(ji,jv)
+               bqsb(ji,jv) = (resdist(ji,jv)*bqsb(ji,jv) + fra(ji)*btr(ji))/veget(ji,jv)
+              ENDIF
+              qsintveg(ji,jv) = qsintveg(ji,jv) + fra(ji)* qstr(ji)
+             ELSE
+              qsintveg(ji,jv) = qsintveg(ji,jv) - qsdq(ji,jv)
+             ENDIF
+             !
+             ! dss is not altered so that this transfer of moisture does not directly 
+             ! affect transpiration
+             IF (gqsb(ji,jv) .LT. min_sechiba) THEN
+                dsg(ji,jv) = zero
+             ELSE
+                dsg(ji,jv) = (dss(ji,jv) * ruu_ch(ji) + gqsb(ji,jv)) &
+                             / ruu_ch(ji)
+             ENDIF
+             dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
+        ENDIF
+      ENDDO
+    ENDDO
+
+    !   Now that the work is done resdist needs an update !
+    DO jv = 1, nvm
+       resdist(:,jv) = veget(:,jv)
+    ENDDO
+
+    !
+    ! Where vegetation fraction is zero, set water to that of bare soil.
+    ! This does not create any additional water.
+    !
+    DO jv = 2, nvm
+      DO ji = 1, kjpindex
+        IF ( veget(ji,jv) .LT. EPS1 ) THEN
+          gqsb(ji,jv) = gqsb(ji,1)
+          bqsb(ji,jv) = bqsb(ji,1)
+          dsg(ji,jv) = dsg(ji,1)
+          dss(ji,jv) = dss(ji,1)
+          dsp(ji,jv) = dsp(ji,1)
+        ENDIF
+      ENDDO
+    ENDDO
+
+    RETURN
+    !
+  END SUBROUTINE hydrolc_vegupd
+  !!
+  !! This routines computes soil processes
+  !!
+  SUBROUTINE hydrolc_soil(kjpindex, vevapnu, precisol, returnflow, irrigation, tot_melt, mx_eau_var, veget, ruu_ch, transpir,&
+       & gqsb, bqsb, dsg, dss, rsol, drysoil_frac, hdry, dsp, runoff, run_off_tot, drainage, humrel, vegstress, &
+       & shumdiag, litterhumdiag)
+    ! 
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex 
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: vevapnu          !! Bare soil evaporation
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: precisol         !! Eau tombee sur le sol
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: returnflow       !! Water returning to the deep reservoir
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: irrigation       !! Irrigation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: tot_melt         !! Total melt   
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: mx_eau_var       !! Profondeur du reservoir contenant le
+                                                                                !! maximum d'eau  
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(in)       :: veget            !! Vegetation map
+    REAL(r_std), DIMENSION (kjpindex), INTENT(in)            :: ruu_ch           !! Quantite d'eau maximum
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(in)        :: transpir         !! Transpiration
+    ! modified fields
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: gqsb             !! Hauteur d'eau dans le reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: bqsb             !! Hauteur d'eau dans le reservoir profond
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dsg              !! Hauteur du reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dss              !! Hauteur au dessus du reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout)     :: dsp              !! Hauteur au dessus du reservoir profond 
+    ! output fields
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)       :: runoff           !! Ruissellement
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: run_off_tot      !! Complete runoff
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: drainage         !! Drainage
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out)      :: humrel           !! Relative humidity
+    REAL(r_std), DIMENSION (kjpindex, nvm), INTENT(out)      :: vegstress   !! Veg. moisture stress (only for vegetation growth)
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out)      :: shumdiag         !! relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: litterhumdiag    !! litter humidity
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: rsol             !! resistance to bare soil evaporation
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: drysoil_frac     !! Fraction of visible fry soil
+    REAL(r_std), DIMENSION (kjpindex), INTENT(out)           :: hdry             !! Dry soil heigth in meters
+
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)                                :: ji,jv, jd
+    REAL(r_std), DIMENSION(kjpindex)               :: zhumrel_lo, zhumrel_up
+    REAL(r_std), DIMENSION(kjpindex,nvm)           :: zeflux                     !! Soil evaporation
+    REAL(r_std), DIMENSION(kjpindex,nvm)           :: zpreci                     !! Soil precipitation
+    LOGICAL, DIMENSION(kjpindex,nvm)              :: warning
+    REAL(r_std)                                    :: gtr, btr
+    REAL(r_std), DIMENSION(kjpindex)               :: mean_dsg
+    LOGICAL                                       :: OnceMore
+    INTEGER(i_std), PARAMETER                     :: nitermax = 100
+    INTEGER(i_std)                                :: niter
+    INTEGER(i_std)                                :: nbad
+    LOGICAL, DIMENSION(kjpindex,nvm)              :: lbad
+    LOGICAL, DIMENSION(kjpindex)                  :: lbad_ij
+    REAL(r_std)                                    :: gqseuil , eausup, wd1
+    REAL(r_std), DIMENSION(nbdl+1)                 :: tmp_dl
+    ! Ajout Nathalie - le 28 Mars 2006 - sur conseils Fred Hourdin
+    ! Modifs stabilite
+    REAL(r_std), DIMENSION(kjpindex,nvm)           :: a_subgrd
+    !
+    !  0. we have only one flux field corresponding to water evaporated from the surface
+    !
+    DO jv=1,nvm
+      DO ji = 1, kjpindex
+        IF ( veget(ji,jv) .GT. zero ) THEN
+          zeflux(ji,jv) = transpir(ji,jv)/veget(ji,jv)
+          zpreci(ji,jv) = precisol(ji,jv)/veget(ji,jv)
+        ELSE
+          zeflux(ji,jv) = zero
+          zpreci(ji,jv) = zero
+        ENDIF
+      ENDDO
+    ENDDO
+    !
+    ! We need a test on the bare soil fraction because we can have bare soil evaporation even when 
+    ! there is no bare soil because of transfers (snow for instance). This should only apply if there
+    ! is vegetation but we do not test this case.
+    ! 
+
+    ! case 1 - there is vegetation and bare soil
+    DO ji = 1, kjpindex
+      IF ( (vegtot(ji) .GT. zero) .AND. (veget(ji,1) .GT. min_sechiba) ) THEN
+        zeflux(ji,1) = vevapnu(ji)/veget(ji,1)
+      ENDIF
+    ENDDO
+
+    ! case 2 - there is vegetation but no bare soil
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( (vegtot(ji) .GT. zero) .AND. (veget(ji,1) .LE. min_sechiba)&
+             & .AND. (veget(ji,jv) .GT. min_sechiba)) THEN
+          zeflux(ji,jv) =  zeflux(ji,jv) + vevapnu(ji)/vegtot(ji)
+        ENDIF
+      ENDDO
+    ENDDO
+
+    !
+    !  0.1 Other temporary variables
+    !
+    tmp_dl(1) = 0
+    tmp_dl(2:nbdl+1) = diaglev(1:nbdl)
+    !
+
+    !
+    ! 1.1 Transpiration for each vegetation type
+    !     Evaporated water is taken out of the ground.
+    !
+    !
+    DO jv=1,nvm
+      DO ji=1,kjpindex
+        !
+        gqsb(ji,jv) = gqsb(ji,jv) - zeflux(ji,jv)
+        !
+        ! 1.2 Add snow and ice melt, troughfall from vegetation and irrigation.
+        !
+        IF(vegtot(ji) .NE. zero) THEN
+           !  snow and ice melt and troughfall from vegetation
+           gqsb(ji,jv) = gqsb(ji,jv) + zpreci(ji,jv) + tot_melt(ji)/vegtot(ji)
+           !
+           ! We take care to add the irrigation only to the vegetated part if possible
+           !
+           IF (ABS(vegtot(ji)-veget(ji,1)) .LE. min_sechiba) THEN
+              gqsb(ji,jv) = gqsb(ji,jv) + irrigation(ji)/vegtot(ji)
+           ELSE
+              IF ( jv > 1 ) THEN
+                 ! Only add the irrigation to the upper soil if there is a reservoir.
+                 ! Without this the water evaporates right away.
+                 IF ( gqsb(ji,jv) > zero ) THEN
+                    gqsb(ji,jv) = gqsb(ji,jv) + irrigation(ji)/(vegtot(ji)-veget(ji,1))
+                 ELSE
+                    bqsb(ji,jv) = bqsb(ji,jv) + irrigation(ji)/(vegtot(ji)-veget(ji,1))
+                 ENDIF
+              ENDIF
+           ENDIF
+           !
+           ! 1.3 We add the water returned from rivers to the lower reservoir.
+           !
+           bqsb(ji,jv) = bqsb(ji,jv) + returnflow(ji)/vegtot(ji)
+           !
+        ENDIF
+        !
+      END DO
+    ENDDO
+    ! 
+    ! 1.3 Computes run-off
+    !
+    runoff(:,:) = zero
+    ! 
+    ! 1.4 Soil moisture is updated
+    !
+    warning(:,:) = .FALSE.
+    DO jv=1,nvm
+      DO ji = 1, kjpindex
+        !
+        runoff(ji,jv) = MAX(gqsb(ji,jv) + bqsb(ji,jv) - mx_eau_var(ji), zero)
+        !
+        IF (mx_eau_var(ji) .LE. (gqsb(ji,jv) + bqsb(ji,jv))) THEN
+            !
+            ! 1.4.1 Plus de reservoir de surface: le sol est sature
+            !       d'eau. Le reservoir de surface est inexistant
+            !       Tout est dans le reservoir de fond.
+            !       Le ruissellement correspond a ce qui deborde.
+            !
+            gqsb(ji,jv) = zero
+            dsg(ji,jv) = zero
+            bqsb(ji,jv) = mx_eau_var(ji)
+            dsp(ji,jv) = zero
+            dss(ji,jv) = dsp (ji,jv)
+
+        ELSEIF ((gqsb(ji,jv) + bqsb(ji,jv)).GE.zero) THEN
+            !
+            IF (gqsb(ji,jv) .GT. dsg(ji,jv) * ruu_ch(ji)) THEN
+                !
+                ! 1.4.2 On agrandit le reservoir de surface
+                !       car il n y a pas eu ruissellement
+                !       et toute l'eau du reservoir de surface
+                !       tient dans un reservoir dont la taille
+                !       est plus importante que l actuel. 
+                !       La hauteur de sol sec dans le reservoir 
+                !       de surface est alors nulle.
+                !       Le reste ne bouge pas.
+                !
+                dsg(ji,jv) = gqsb(ji,jv) / ruu_ch(ji)
+                dss(ji,jv) = zero
+            ELSEIF (gqsb(ji,jv) .GT. zero ) THEN 
+                !
+                ! 1.4.3 L eau tient dans le reservoir de surface 
+                !       tel qu il existe. 
+                !       Calcul de la nouvelle hauteur de sol sec
+                !       dans la couche de surface.
+                !       Le reste ne bouge pas.
+                !
+                dss(ji,jv) = ((dsg(ji,jv) * ruu_ch(ji)) - gqsb(ji,jv)) / ruu_ch(ji) 
+            ELSE
+                !
+                ! 1.4.4 La quantite d eau du reservoir de surface
+                !       est negative. Cela revient a enlever
+                !       cette quantite au reservoir profond.
+                !       Le reservoir de surface est alors vide.
+                !       (voir aussi 1.4.1)
+                !
+                bqsb(ji,jv) = bqsb(ji,jv) + gqsb(ji,jv)
+                dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
+                gqsb(ji,jv) = zero
+                dsg(ji,jv) = zero
+                dss(ji,jv) = dsp(ji,jv)
+            END IF
+
+        ELSE 
+            !
+            ! 1.4.5 Le reservoir profond est aussi asseche.
+            !       La quantite d eau a enlever depasse la quantite 
+            !       disponible dans le reservoir profond.
+            !
+            !
+            ! Ceci ne devrait jamais arriver plus d'une fois par point. C-a-d une fois la valeur negative
+            ! atteinte les flux doivent etre nuls. On ne signal que ce cas donc.
+            ! 
+            IF ( ( zeflux(ji,jv) .GT. zero ) .AND. &
+                 ( gqsb(ji,jv) + bqsb(ji,jv) .LT. -1.e-10 ) ) THEN
+               warning(ji,jv) = .TRUE.
+               ! WRITE (numout,*) 'WARNING! Soil Moisture will be negative' 
+               ! WRITE (numout,*) 'ji, jv = ', ji,jv
+               ! WRITE (numout,*) 'mx_eau_var = ', mx_eau_var(ji)
+               ! WRITE (numout,*) 'veget, resdist =', veget(ji,jv), resdist(ji,jv)
+               ! WRITE (numout,*) 'bqsb = ', bqsb(ji,jv)
+               ! WRITE (numout,*) 'gqsb = ', gqsb(ji,jv)
+               ! WRITE (numout,*) 'dss = ', dss(ji,jv)
+               ! WRITE (numout,*) 'dsg = ', dsg(ji,jv)
+               ! WRITE (numout,*) 'dsp = ', dsp(ji,jv)
+               ! WRITE (numout,*) 'humrel = ', humrel(ji, jv)
+               ! WRITE (numout,*) 'Soil evaporation = ', zeflux(ji,jv)
+               ! WRITE (numout,*) 'input = ',precisol(ji, jv), tot_melt(ji)
+               ! WRITE (numout,*) '============================'
+            ENDIF
+            !
+            bqsb(ji,jv) = gqsb(ji,jv) + bqsb(ji,jv)
+            dsp(ji,jv) = dpu_cste
+            gqsb(ji,jv) = zero
+            dsg(ji,jv) = zero
+            dss(ji,jv) = dsp(ji,jv)
+            !
+        ENDIF
+        !
+      ENDDO
+    ENDDO
+    !
+    nbad = COUNT( warning(:,:) .EQV. .TRUE. )
+    IF ( nbad .GT. 0 ) THEN
+      WRITE(numout,*) 'hydrolc_soil: WARNING! Soil moisture was negative at', &
+                       nbad, ' points:'
+      !DO jv = 1, nvm
+      !  DO ji = 1, kjpindex
+      !    IF ( warning(ji,jv) ) THEN
+      !      WRITE(numout,*) '  ji,jv = ', ji,jv
+      !      WRITE (numout,*) 'mx_eau_var = ', mx_eau_var(ji)
+      !      WRITE (numout,*) 'veget, resdist =', veget(ji,jv), resdist(ji,jv)
+      !      WRITE (numout,*) 'bqsb = ', bqsb(ji,jv)
+      !      WRITE (numout,*) 'gqsb = ', gqsb(ji,jv)
+      !      WRITE (numout,*) 'runoff = ',runoff(ji,jv)
+      !      WRITE (numout,*) 'dss = ', dss(ji,jv)
+      !      WRITE (numout,*) 'dsg = ', dsg(ji,jv)
+      !      WRITE (numout,*) 'dsp = ', dsp(ji,jv)
+      !      WRITE (numout,*) 'humrel = ', humrel(ji, jv)
+      !      WRITE (numout,*) 'Soil evaporation = ', zeflux(ji,jv)
+      !      WRITE (numout,*) 'Soil precipitation = ',zpreci(ji,jv)
+      !      WRITE (numout,*) 'input = ',precisol(ji, jv), tot_melt(ji)
+      !      WRITE (numout,*) 'returnflow = ',returnflow(ji)
+      !      WRITE (numout,*) '============================'
+      !    ENDIF
+      !  ENDDO
+      !ENDDO
+    ENDIF
+    !
+    !  2.0 Very large upper reservoirs or very close upper and lower reservoirs
+    !         can be deadlock situations for Choisnel. They are handled here
+    !
+    IF (long_print) WRITE(numout,*)  'hydro_soil 2.0 : Resolve deadlocks'
+    DO jv=1,nvm
+      DO ji=1,kjpindex
+        !
+        !   2.1 the two reservoirs are very close to each other
+        !
+        IF ( ABS(dsp(ji,jv)-dsg(ji,jv)) .LT. min_resdis ) THEN
+            bqsb(ji,jv) = bqsb(ji,jv) + gqsb(ji,jv)
+            dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
+            gqsb(ji,jv) = zero
+            dsg(ji,jv) = zero
+            dss(ji,jv) = dsp(ji,jv)
+        ENDIF
+        !
+        !  2.2 Draine some water from the upper to the lower reservoir
+        !
+        gqseuil = min_resdis * deux * ruu_ch(ji)
+        eausup = dsg(ji,jv) * ruu_ch(ji)
+        wd1 = .75*eausup
+        !
+        IF (eausup .GT. gqseuil) THEN
+            gdrainage(ji,jv) = min_drain *  (gqsb(ji,jv)/eausup)
+            !
+            IF ( gqsb(ji,jv) .GE. wd1 .AND. dsg(ji,jv) .GT. 0.10 ) THEN
+                !
+                gdrainage(ji,jv) = gdrainage(ji,jv) + &
+                   (max_drain-min_drain)*((gqsb(ji,jv)-wd1) / (eausup-wd1))**exp_drain
+                !
+            ENDIF
+            !
+            gdrainage(ji,jv)=MIN(gdrainage(ji,jv), MAX(gqsb(ji,jv), zero))
+            !
+        ELSE
+            gdrainage(ji,jv)=zero
+        ENDIF
+        !
+        gqsb(ji,jv) = gqsb(ji,jv) -  gdrainage(ji,jv)
+        bqsb(ji,jv) = bqsb(ji,jv) + gdrainage(ji,jv)
+        dsg(ji,jv) = dsg(ji,jv) -  gdrainage(ji,jv) / ruu_ch(ji)
+        dsp(ji,jv) = dpu_cste - bqsb(ji,jv)/ruu_ch(ji)
+        !
+        !
+      ENDDO
+      !
+    ENDDO
+
+    !
+    !   3.0 Diffusion of water between the reservoirs of the different plants
+    !
+    IF (long_print) WRITE(numout,*)  'hydrolc_soil 3.0 : Vertical diffusion'
+
+    mean_bqsb(:) = zero
+    mean_gqsb(:) = zero
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        IF ( vegtot(ji) .GT. zero ) THEN
+          mean_bqsb(ji) = mean_bqsb(ji) + veget(ji,jv)/vegtot(ji)*bqsb(ji,jv)
+          mean_gqsb(ji) = mean_gqsb(ji) + veget(ji,jv)/vegtot(ji)*gqsb(ji,jv)
+        ENDIF
+      ENDDO
+    ENDDO
+
+    OnceMore = .TRUE.
+    niter = 0
+
+!YM
+    lbad_ij(:)=.TRUE.
+    
+    ! nitermax prevents infinite loops (should actually never occur)
+    DO WHILE ( OnceMore .AND. ( niter .LT. nitermax ) ) 
+      !
+      niter = niter + 1
+
+!YM
+      DO jv = 1, nvm
+        !
+        DO ji = 1, kjpindex
+           IF (lbad_ij(ji)) THEN
+              IF ( veget(ji,jv) .GT. zero ) THEN
+                 !
+                 bqsb(ji,jv) = mean_bqsb(ji)
+                 dsp(ji,jv) = dpu_cste - bqsb(ji,jv)/ruu_ch(ji)
+              ENDIF
+           ENDIF
+           !
+        ENDDO
+      ENDDO
+      !
+      ! where do we have to do something?
+      lbad(:,:) = ( ( dsp(:,:) .LT. dsg(:,:) ) .AND. &
+                    ( dsg(:,:) .GT. zero ) .AND. &
+                    ( veget(:,:) .GT. zero ) )
+      !
+      ! if there are no such points any more, we'll do no more iteration
+      IF ( COUNT( lbad(:,:) ) .EQ. 0 ) OnceMore = .FALSE.
+     
+      DO ji = 1, kjpindex
+        IF (COUNT(lbad(ji,:)) == 0 ) lbad_ij(ji)=.FALSE.
+      ENDDO
+      !
+      DO jv = 1, nvm
+!YM
+!        !
+!        DO ji = 1, kjpindex
+!          IF ( veget(ji,jv) .GT. zero ) THEN
+!            !
+!            bqsb(ji,jv) = mean_bqsb(ji)
+!            dsp(ji,jv) = dpu_cste - bqsb(ji,jv)/ruu_ch(ji)
+!          ENDIF
+!          !
+!        ENDDO
+        !
+        DO ji = 1, kjpindex
+          IF ( lbad(ji,jv) ) THEN
+            !
+            runoff(ji,jv) = runoff(ji,jv) + &
+                            MAX( bqsb(ji,jv) + gqsb(ji,jv) - mx_eau_var(ji), zero)
+            !
+            bqsb(ji,jv) = MIN( bqsb(ji,jv) + gqsb(ji,jv), mx_eau_var(ji))
+            !
+            gqsb(ji,jv) = zero
+            dsp(ji,jv) = dpu_cste - bqsb(ji,jv)/ruu_ch(ji)
+            dss(ji,jv) = dsp(ji,jv)
+            dsg(ji,jv) = zero
+            !
+          ENDIF
+        ENDDO
+        !
+      ENDDO
+      !
+      mean_bqsb(:) = zero
+      mean_gqsb(:) = zero
+      DO jv = 1, nvm
+        DO ji = 1, kjpindex
+          IF ( vegtot(ji) .GT. zero ) THEN
+            mean_bqsb(ji) = mean_bqsb(ji) + veget(ji,jv)/vegtot(ji)*bqsb(ji,jv)
+            mean_gqsb(ji) = mean_gqsb(ji) + veget(ji,jv)/vegtot(ji)*gqsb(ji,jv)
+          ENDIF
+        ENDDO
+      ENDDO
+      !
+    ENDDO
+
+    !
+    ! 4. computes total runoff
+    !
+    IF (long_print) WRITE(numout,*)  'hydrolc_soil 4.0: Computes total runoff'
+
+    run_off_tot(:) = zero
+    DO ji = 1, kjpindex
+      IF ( vegtot(ji) .GT. zero ) THEN
+       DO jv = 1, nvm
+        run_off_tot(ji) = run_off_tot(ji) + (runoff(ji,jv)*veget(ji,jv))
+       ENDDO
+      ELSE
+        run_off_tot(ji) = tot_melt(ji) + irrigation(ji)
+      ENDIF
+    ENDDO
+    !
+    ! 4.1 We estimate some drainage !
+    !
+    drainage(:) = 0.95 * run_off_tot(:)
+    run_off_tot(:) = run_off_tot(:) - drainage(:)
+    !
+    ! 5. Some averaged diagnostics
+    !
+    IF (long_print) WRITE(numout,*)  'hydro_soil 5.0: Diagnostics'
+
+    !
+    ! 5.1 reset dsg if necessary
+    !
+    WHERE (gqsb(:,:) .LE. zero) dsg(:,:) = zero
+    !
+    DO ji=1,kjpindex
+      !
+      !  5.2 Compute an average moisture profile
+      !
+      mean_dsg(ji) = mean_gqsb(ji)/ruu_ch(ji)
+      !
+    ENDDO
+
+    !
+    ! 6. Compute the moisture stress on vegetation
+    !
+    IF (long_print) WRITE(numout,*)  'hydro_soil 6.0 : Moisture stress'
+
+    a_subgrd(:,:) = zero
+
+    DO jv = 1, nvm
+      DO ji=1,kjpindex
+         !
+         ! computes relative surface humidity
+         !
+         ! Only use the standard formulas if total soil moisture is larger than zero.
+         ! Else stress functions are set to zero. 
+         ! This will avoid that large negative soil moisture accumulate over time by the
+         ! the creation of small skin reservoirs which evaporate quickly.
+         !
+         IF ( gqsb(ji,jv)+bqsb(ji,jv) .GT. zero ) THEN
+            !
+            IF (dsg(ji,jv).EQ. zero .OR. gqsb(ji,jv).EQ.zero) THEN
+               humrel(ji,jv) = EXP( - humcste(jv) * dpu_cste * (dsp(ji,jv)/dpu_cste) )
+               dsg(ji,jv) = zero
+               !
+               ! if the dry soil height is larger than the one corresponding
+               ! to the wilting point, or negative lower soil moisture : humrel is 0.0
+               !
+               IF (dsp(ji,jv).GT.(dpu_cste - (qwilt / ruu_ch(ji))) .OR. bqsb(ji,jv).LT.zero) THEN
+                  humrel(ji,jv) = zero
+               ENDIF
+               !
+               ! In this case we can take for vegetation growth the same values for humrel and vegstress
+               !
+               vegstress(ji,jv) = humrel(ji,jv)
+               !
+            ELSE
+
+               ! Corrections Nathalie - le 28 Mars 2006 - sur conseils Fred Hourdin
+               !zhumrel_lo(ji) = EXP( - humcste(jv) * dpu_cste * (dsp(ji,jv)/dpu_cste) )
+               !zhumrel_up(ji) = EXP( - humcste(jv) * dpu_cste * (dss(ji,jv)/dsg(ji,jv)) )
+               !humrel(ji,jv) = MAX(zhumrel_lo(ji),zhumrel_up(ji))
+               !
+               ! As we need a slower variable for vegetation growth the stress is computed
+               ! differently than in humrel.
+               !
+               zhumrel_lo(ji) = EXP( - humcste(jv) * dsp(ji,jv))
+               zhumrel_up(ji) = EXP( - humcste(jv) * dss(ji,jv))
+               ! Ajouts Nathalie - Fred - le 28 Mars 2006
+               a_subgrd(ji,jv)=MIN(MAX(dsg(ji,jv)-dss(ji,jv),zero)/dsg_min,un)
+               humrel(ji,jv)=a_subgrd(ji,jv)*zhumrel_up(ji)+(un-a_subgrd(ji,jv))*zhumrel_lo(ji)
+               !
+               vegstress(ji,jv) = zhumrel_lo(ji) + zhumrel_up(ji) - EXP( - humcste(jv) * dsg(ji,jv) ) 
+               !
+            ENDIF
+            !
+         ELSE
+            !
+            humrel(ji,jv) = zero
+            vegstress(ji,jv) = zero
+            !
+         ENDIF
+        !
+      ENDDO
+    ENDDO
+
+    !
+    ! 7. Diagnostics which are needed to carry information to other modules
+    !
+    ! 7.2 Relative soil moisture
+    !
+    DO jd = 1,nbdl
+      DO ji = 1, kjpindex
+         IF ( tmp_dl(jd+1) .LT. mean_dsg(ji)) THEN
+            shumdiag(ji,jd) = mean_gqsb(ji)/mx_eau_var(ji)
+         ELSE
+            IF ( tmp_dl(jd) .LT. mean_dsg(ji)) THEN
+               gtr = (mean_dsg(ji)-tmp_dl(jd))/(tmp_dl(jd+1)-tmp_dl(jd))
+               btr = 1 - gtr
+               shumdiag(ji,jd) = gtr*mean_gqsb(ji)/mx_eau_var(ji) + &
+                    & btr*mean_bqsb(ji)/mx_eau_var(ji)
+            ELSE
+               shumdiag(ji,jd) = mean_bqsb(ji)/mx_eau_var(ji)
+            ENDIF
+         ENDIF
+         shumdiag(ji,jd) = MAX(MIN(shumdiag(ji,jd), un), zero)
+      ENDDO
+    ENDDO
+
+    ! The fraction of visibly dry soil (dry when dss(:,1) = 0.1 m)
+    drysoil_frac(:) = MIN(MAX(dss(:,1),zero)*10._r_std, un)
+
+    ! Correction Nathalie - le 28 Mars 2006 - re-ecriture drysoil_frac/hdry - Fred Hourdin
+    ! revu 22 novembre 2007
+    hdry(:) = a_subgrd(:,1)*dss(:,1) + (un-a_subgrd(:,1))*dsp(:,1)
+    !
+    ! Compute the resistance to bare soil evaporation.
+    !
+    rsol(:) = -un
+    DO ji = 1, kjpindex
+       IF (veget(ji,1) .GE. min_sechiba) THEN
+          !
+          ! Correction Nathalie - le 28 mars 2006 - sur conseils Fred Hourdin
+          ! on modifie le rsol pour que la resistance croisse subitement si on s'approche
+          ! du fond. En gros, rsol=hdry*rsol_cste pour hdry < 1m70
+          !rsol(ji) = dss(ji,1) * rsol_cste
+          rsol(ji) =  ( hdry(ji) + un/(10.*(dpu_cste - hdry(ji))+1.e-10)**2 ) * rsol_cste
+       ENDIF
+    ENDDO
+
+    !
+    ! 8. litter humidity.
+    !
+
+    litterhumdiag(:) = EXP( - hdry(:) / hcrit_litter )
+
+    ! special case: it has just been raining a few drops. The upper soil
+    ! reservoir is ridiculously small, but the dry soil height is zero.
+    ! Don't take it into account.
+
+    WHERE ( ( hdry(:) .LT. min_sechiba ) .AND. &
+            ( mean_dsg(:) .GT. min_sechiba ) .AND. ( mean_dsg(:) .LT. 5.E-4 ) )
+      litterhumdiag(:) = zero
+    ENDWHERE
+
+    !
+    IF (long_print) WRITE (numout,*) ' hydrolc_soil done '
+
+  END SUBROUTINE hydrolc_soil
+  !!
+  !! This routines checks the water balance. First it gets the total
+  !! amount of water and then it compares the increments with the fluxes.
+  !! The computation is only done over the soil area as over glaciers (and lakes?)
+  !! we do not have water conservation.
+  !!
+  !! This verification does not make much sense in REAL*4 as the precision is the same as some
+  !! of the fluxes
+  !!
+  SUBROUTINE hydrolc_waterbal (kjpindex, index, first_call, dtradia, veget, totfrac_nobio, qsintveg, snow, snow_nobio,&
+       & precip_rain, precip_snow, returnflow, irrigation, tot_melt, vevapwet, transpir, vevapnu, vevapsno, run_off_tot, &
+       & drainage)
+    !
+    !
+    !
+    INTEGER(i_std), INTENT (in)                        :: kjpindex     !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: index        !! Indeces of the points on the map
+    LOGICAL, INTENT (in)                              :: first_call   !! At which time is this routine called ?
+    REAL(r_std), INTENT (in)                           :: dtradia      !! Time step in seconds
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: veget        !! Fraction of vegetation type 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: totfrac_nobio!! Total fraction of continental ice+lakes+...
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintveg     !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow         !! Snow mass [Kg/m^2]
+    REAL(r_std), DIMENSION (kjpindex,nnobio), INTENT(inout)  :: snow_nobio    !!Ice water balance
+    !
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_rain  !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: precip_snow  !! Snow precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: returnflow   !! Water returning from routing to the deep reservoir
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: irrigation   !! Water from irrigation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: tot_melt     !! Total melt
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: vevapwet     !! Interception loss
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: transpir     !! Transpiration
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: vevapnu      !! Bare soil evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: vevapsno     !! Snow evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: run_off_tot  !! Total runoff
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: drainage     !! Drainage
+    !
+    !  LOCAL
+    !
+    INTEGER(i_std) :: ji, jv, jn
+    REAL(r_std) :: allowed_err
+    REAL(r_std),DIMENSION (kjpindex) :: watveg, delta_water, tot_flux, sum_snow_nobio, sum_vevapwet, sum_transpir
+    !
+    !
+    !
+    IF ( first_call ) THEN
+
+       tot_water_beg(:) = zero
+       watveg(:) = zero
+       sum_snow_nobio(:) = zero
+!cdir NODEP
+       DO jv = 1, nvm
+          watveg(:) = watveg(:) + qsintveg(:,jv)
+       ENDDO
+!cdir NODEP
+       DO jn = 1, nnobio
+          sum_snow_nobio(:) = sum_snow_nobio(:) + snow_nobio(:,jn)
+       ENDDO
+!cdir NODEP
+       DO ji = 1, kjpindex
+          tot_water_beg(ji) = (mean_bqsb(ji) + mean_gqsb(ji))*vegtot(ji) + &
+            &  watveg(ji) + snow(ji) + sum_snow_nobio(ji)
+       ENDDO
+       tot_water_end(:) = tot_water_beg(:)
+
+       RETURN
+
+    ENDIF
+    !
+    !  Check the water balance
+    !
+    tot_water_end(:) = zero
+    !
+    DO ji = 1, kjpindex
+       !
+       ! If the fraction of ice, lakes, etc. does not complement the vegetation fraction then we do not
+       ! need to go any further
+       !
+       ! Modif Nathalie
+       ! IF ( (un - (totfrac_nobio(ji) + vegtot(ji))) .GT. EPSILON(un) ) THEN
+       IF ( (un - (totfrac_nobio(ji) + vegtot(ji))) .GT. (100*EPSILON(un)) ) THEN
+          WRITE(numout,*) 'HYDROL problem in vegetation or frac_nobio on point ', ji
+          WRITE(numout,*) 'totfrac_nobio : ', totfrac_nobio(ji)
+          WRITE(numout,*) 'vegetation fraction : ', vegtot(ji)
+          !STOP 'in hydrolc_waterbal'
+       ENDIF
+    ENDDO
+       !
+    watveg(:) = zero
+    sum_vevapwet(:) = zero
+    sum_transpir(:) = zero
+    sum_snow_nobio(:) = zero
+!cdir NODEP
+    DO jv = 1,nvm
+       watveg(:) = watveg(:) + qsintveg(:,jv)
+       sum_vevapwet(:) = sum_vevapwet(:) + vevapwet(:,jv)
+       sum_transpir(:) = sum_transpir(:) + transpir(:,jv)
+    ENDDO
+!cdir NODEP
+    DO jn = 1,nnobio
+       sum_snow_nobio(:) = sum_snow_nobio(:) + snow_nobio(:,jn)
+    ENDDO
+    !
+!cdir NODEP
+    DO ji = 1, kjpindex
+       tot_water_end(ji) = (mean_bqsb(ji) + mean_gqsb(ji))*vegtot(ji) + &
+            & watveg(ji) + snow(ji) + sum_snow_nobio(ji)
+    ENDDO
+    !
+    DO ji = 1, kjpindex
+       !
+       delta_water(ji) = tot_water_end(ji) - tot_water_beg(ji)
+       !
+       tot_flux(ji) =  precip_rain(ji) + precip_snow(ji) + returnflow(ji) + irrigation(ji) - &
+             & sum_vevapwet(ji) - sum_transpir(ji) - vevapnu(ji) - vevapsno(ji) - &
+             & run_off_tot(ji) - drainage(ji) 
+       !
+    ENDDO
+    !
+       !  Set some precision ! This is a wild guess and corresponds to what works on an IEEE machine
+       !  under double precision (REAL*8).
+       !
+       allowed_err = 50000*EPSILON(un) 
+       !
+    DO ji = 1, kjpindex
+       IF ( ABS(delta_water(ji)-tot_flux(ji)) .GT. allowed_err ) THEN
+          WRITE(numout,*) 'HYDROL does not conserve water. The erroneous point is : ', ji
+          WRITE(numout,*) 'The error in mm/d is :', (delta_water(ji)-tot_flux(ji))/dtradia*one_day, &
+               & ' and in mm/dt : ', delta_water(ji)-tot_flux(ji)
+          WRITE(numout,*) 'delta_water : ', delta_water(ji), ' tot_flux : ', tot_flux(ji)
+          WRITE(numout,*) 'Actual and allowed error : ', ABS(delta_water(ji)-tot_flux(ji)), allowed_err
+          WRITE(numout,*) 'vegtot : ', vegtot(ji)
+          WRITE(numout,*) 'precip_rain : ', precip_rain(ji)
+          WRITE(numout,*) 'precip_snow : ',  precip_snow(ji)
+          WRITE(numout,*) 'Water from irrigation : ', returnflow(ji), irrigation(ji)
+          WRITE(numout,*) 'Total water in soil :', mean_bqsb(ji) + mean_gqsb(ji)
+          WRITE(numout,*) 'Water on vegetation :', watveg(ji)
+          WRITE(numout,*) 'Snow mass :', snow(ji)
+          WRITE(numout,*) 'Snow mass on ice :', sum_snow_nobio(ji)
+          WRITE(numout,*) 'Melt water :', tot_melt(ji)
+          WRITE(numout,*) 'evapwet : ', vevapwet(ji,:)
+          WRITE(numout,*) 'transpir : ', transpir(ji,:)
+          WRITE(numout,*) 'evapnu, evapsno : ', vevapnu(ji), vevapsno(ji)
+
+          WRITE(numout,*) 'drainage : ', drainage(ji)
+          STOP 'in hydrolc_waterbal'
+       ENDIF
+       !
+    ENDDO
+    !
+    ! Transfer the total water amount at the end of the current timestep top the begining of the next one.
+    !
+    tot_water_beg = tot_water_end
+    !
+  END SUBROUTINE hydrolc_waterbal
+  !
+  !  This routine computes the changes in soil moisture and interception storage for the ALMA outputs
+  !
+  SUBROUTINE hydrolc_alma (kjpindex, index, first_call, qsintveg, snow, snow_nobio, soilwet)
+    !
+    INTEGER(i_std), INTENT (in)                        :: kjpindex     !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)   :: index        !! Indeces of the points on the map
+    LOGICAL, INTENT (in)                              :: first_call   !! At which time is this routine called ?
+    !
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)  :: qsintveg     !! Water on vegetation due to interception
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow         !! Snow water equivalent
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)      :: soilwet     !! Soil wetness
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (in) :: snow_nobio     !! Water balance on ice, lakes, .. [Kg/m^2]
+    !
+    !  LOCAL
+    !
+    INTEGER(i_std) :: ji
+    REAL(r_std) :: watveg 
+    !
+    !
+    !
+    IF ( first_call ) THEN
+
+       tot_watveg_beg(:) = zero
+       tot_watsoil_beg(:) = zero
+       snow_beg(:)        = zero 
+       !
+       DO ji = 1, kjpindex
+          watveg = SUM(qsintveg(ji,:))
+          tot_watveg_beg(ji) = watveg
+          tot_watsoil_beg(ji) = mean_bqsb(ji) + mean_gqsb(ji)
+          snow_beg(ji)        = snow(ji)+ SUM(snow_nobio(ji,:))  
+       ENDDO
+       !
+       tot_watveg_end(:) = tot_watveg_beg(:)
+       tot_watsoil_end(:) = tot_watsoil_beg(:)
+       snow_end(:)        = snow_beg(:)
+
+       RETURN
+
+    ENDIF
+    !
+    ! Calculate the values for the end of the time step 
+    !
+    tot_watveg_end(:) = zero
+    tot_watsoil_end(:) = zero
+    snow_end(:) = zero
+    delintercept(:) = zero
+    delsoilmoist(:) = zero
+    delswe(:) = zero
+    !
+    DO ji = 1, kjpindex
+       watveg = SUM(qsintveg(ji,:))
+       tot_watveg_end(ji) = watveg
+       tot_watsoil_end(ji) = mean_bqsb(ji) + mean_gqsb(ji)
+       snow_end(ji) = snow(ji)+ SUM(snow_nobio(ji,:))
+       !  
+       delintercept(ji) = tot_watveg_end(ji) - tot_watveg_beg(ji)
+       delsoilmoist(ji) = tot_watsoil_end(ji) - tot_watsoil_beg(ji)
+       delswe(ji)       = snow_end(ji) - snow_beg(ji)
+       !
+       !
+    ENDDO
+    !
+    !
+    ! Transfer the total water amount at the end of the current timestep top the begining of the next one.
+    !
+    tot_watveg_beg = tot_watveg_end
+    tot_watsoil_beg = tot_watsoil_end
+    snow_beg(:) = snow_end(:)
+    !
+    DO ji = 1,kjpindex
+       soilwet(ji) = tot_watsoil_end(ji) / mx_eau_var(ji)
+    ENDDO
+    !
+  END SUBROUTINE hydrolc_alma
+  !-
+  SUBROUTINE hydrolc_hdiff(kjpindex, dtradia, veget, ruu_ch, gqsb, bqsb, dsg, dss, dsp)
+
+    INTEGER(i_std), INTENT (in)                          :: kjpindex     !! Domain size
+    REAL(r_std), INTENT (in)                             :: dtradia      !! time step (s)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)    :: veget        !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: ruu_ch       !! Quantite d'eau maximum
+
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: gqsb         !! Hauteur d'eau dans le reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: bqsb         !! Hauteur d'eau dans le reservoir profond
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsg          !! Hauteur du reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dss          !! Hauteur au dessus du reservoir de surface
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(inout) :: dsp          !! Hauteur au dessus du reservoir profond
+
+    REAL(r_std), DIMENSION (kjpindex)                    :: bqsb_mean
+    REAL(r_std), DIMENSION (kjpindex)                    :: gqsb_mean
+    REAL(r_std), DIMENSION (kjpindex)                    :: dss_mean
+    REAL(r_std), DIMENSION (kjpindex)                    :: vegtot
+    REAL(r_std)                                          :: x
+    INTEGER(i_std)                                      :: ji,jv
+    REAL(r_std), SAVE                                    :: tau_hdiff
+    LOGICAL, SAVE                                       :: firstcall=.TRUE.
+
+    IF ( firstcall ) THEN
+
+      !Config  Key  = HYDROL_TAU_HDIFF
+      !Config  Desc = time scale (s) for horizontal diffusion of water
+      !Config  Def  = one_day
+      !Config  If   = HYDROL_OK_HDIFF
+      !Config  Help = Defines how fast diffusion occurs horizontally between
+      !Config         the individual PFTs' water reservoirs. If infinite, no
+      !Config         diffusion.
+
+      tau_hdiff = one_day
+      CALL getin_p('HYDROL_TAU_HDIFF',tau_hdiff)
+
+      WRITE (numout,*) 'Hydrol: Horizontal diffusion, tau (s)=',tau_hdiff
+
+      firstcall = .FALSE.
+
+    ENDIF
+
+    ! Calculate mean values
+    ! could be done with SUM instruction but this kills vectorization
+    !
+    bqsb_mean(:) = zero
+    gqsb_mean(:) = zero
+    dss_mean(:) = zero
+    vegtot(:) = zero
+    !
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        bqsb_mean(ji) = bqsb_mean(ji) + veget(ji,jv)*bqsb(ji,jv)
+        gqsb_mean(ji) = gqsb_mean(ji) + veget(ji,jv)*gqsb(ji,jv)
+        dss_mean(ji) = dss_mean(ji) + veget(ji,jv)*dss(ji,jv)
+        vegtot(ji) = vegtot(ji) + veget(ji,jv)
+      ENDDO
+    ENDDO
+ 
+    DO ji = 1, kjpindex
+      IF (vegtot(ji) .GT. zero) THEN
+        bqsb_mean(ji) = bqsb_mean(ji)/vegtot(ji)
+        gqsb_mean(ji) = gqsb_mean(ji)/vegtot(ji)
+        dss_mean(ji) = dss_mean(ji)/vegtot(ji)
+      ENDIF
+    ENDDO
+
+    ! relax values towards mean.
+    !
+    x = MAX( zero, MIN( dtradia/tau_hdiff, un ) )
+    !
+    DO jv = 1, nvm
+      DO ji = 1, kjpindex
+        !
+        bqsb(ji,jv) = (un-x) * bqsb(ji,jv) + x * bqsb_mean(ji)
+        gqsb(ji,jv) = (un-x) * gqsb(ji,jv) + x * gqsb_mean(ji)
+        dss(ji,jv) = (un-x) * dss(ji,jv) + x * dss_mean(ji)
+        !
+        IF (gqsb(ji,jv) .LT. min_sechiba) THEN
+          dsg(ji,jv) = zero
+        ELSE
+          dsg(ji,jv) = (dss(ji,jv) * ruu_ch(ji) + gqsb(ji,jv)) / ruu_ch(ji)
+        ENDIF
+        dsp(ji,jv) = dpu_cste - bqsb(ji,jv) / ruu_ch(ji)
+        !
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE hydrolc_hdiff
+  !
+END MODULE hydrolc
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/intersurf.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/intersurf.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/intersurf.f90	(revision 55)
@@ -0,0 +1,5478 @@
+
+!! This subroutine is the interface between the main program 
+!! (LMDZ or dim2_driver) and SECHIBA.
+!! - Input fields are gathered to keep just continental points
+!! - call sechiba_main That's SECHIBA process.
+!! - Output fields are scattered to complete global fields
+!!
+!! @call sechiba_main
+!! @Version : $Revision$, $Date$
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!!
+!f90doc MODULEintersurf
+MODULE intersurf
+
+  USE IOIPSL
+
+  USE defprec
+  USE sechiba
+  USE constantes
+  USE constantes_soil
+  USE constantes_veg
+  USE parallel
+  USE watchout
+  USE solar
+  USE grid
+!    USE Write_Field_p
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC :: intersurf_main, stom_define_history, intsurf_time
+
+  INTERFACE intersurf_main
+    MODULE PROCEDURE intersurf_main_2d, intersurf_main_1d, intersurf_gathered, intersurf_gathered_2m
+  END INTERFACE
+  !
+  !  Global variables
+  !
+  INTEGER(i_std),PARAMETER                           :: max_hist_level = 11
+  !
+  LOGICAL, SAVE                                     :: l_first_intersurf=.TRUE. !! Initialisation has to be done one time
+  !
+  INTEGER(i_std), SAVE                               :: hist_id, rest_id        !! IDs for history and restart files
+  INTEGER(i_std), SAVE                               :: hist2_id                !! ID for the second history files (Hi-frequency ?)
+  INTEGER(i_std), SAVE                               :: hist_id_stom, hist_id_stom_IPCC, rest_id_stom !! Dito for STOMATE
+  REAL(r_std), SAVE                                  :: dw                      !! frequency of history write (sec.)
+  !
+  INTEGER(i_std), SAVE                               :: itau_offset  !! This offset is used to phase the 
+  !                                                                 !! calendar of the GCM or the driver.
+  REAL(r_std)                                        :: date0_shifted
+  !
+  TYPE(control_type), SAVE                          :: control_flags !! Flags that (de)activate parts of the model
+  !
+  !
+  !! first day of this year
+  REAL(r_std) :: julian0
+  !
+  LOGICAL :: check_INPUTS = .FALSE.         !! (very) long print of INPUTs in intersurf 
+  LOGICAL, SAVE :: OFF_LINE_MODE = .FALSE. 
+  !
+CONTAINS
+  !
+  !f90doc CONTAINS
+  ! 
+  SUBROUTINE intersurf_main_2d (kjit, iim, jjm, kjpindex, kindex, xrdt, &
+     & lrestart_read, lrestart_write, lon, lat, zcontfrac, zneighbours, zresolution, date0, &
+! First level conditions
+     & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
+! Variables for the implicit coupling
+     & cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+     & precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+     & vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
+! Surface temperatures and surface properties
+     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0) 
+    
+    ! routines called : sechiba_main
+    !
+    IMPLICIT NONE
+    !    
+    ! interface description for dummy arguments
+    ! input scalar 
+    INTEGER(i_std),INTENT (in)                            :: kjit          !! Time step number
+    INTEGER(i_std),INTENT (in)                            :: iim, jjm      !! Dimension of input fields
+    INTEGER(i_std),INTENT (in)                            :: kjpindex      !! Number of continental points
+    REAL(r_std),INTENT (in)                               :: xrdt          !! Time step in seconds
+    LOGICAL, INTENT (in)                                 :: lrestart_read !! Logical for _restart_ file to read
+    LOGICAL, INTENT (in)                                 :: lrestart_write!! Logical for _restart_ file to write'
+    REAL(r_std), INTENT (in)                              :: date0         !! Date at which kjit = 0
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)      :: kindex        !! Index for continental points
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: u             !! Lowest level wind speed
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: v             !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: zlev          !! Height of first layer
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: qair          !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: precip_rain   !! Rain precipitation
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: precip_snow   !! Snow precipitation
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: lwdown        !! Down-welling long-wave flux 
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: swnet         !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: swdown        !! Downwelling surface short-wave flux
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: temp_air      !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: epot_air      !! Air potential energy
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: ccanopy       !! CO2 concentration in the canopy
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: petAcoef      !! Coeficients A from the PBL resolution
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: peqAcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: petBcoef      !! Coeficients B from the PBL resolution
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: peqBcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(inout)          :: cdrag         !! Cdrag
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: pb            !! Lowest level pressure
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: lon, lat      !! Geographical coordinates
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in)             :: zcontfrac      !! Fraction of continent in the grid
+    INTEGER, DIMENSION (iim,jjm,8), INTENT(in)             :: zneighbours   !! land neighbours
+    REAL(r_std),DIMENSION (iim,jjm,2), INTENT(in)           :: zresolution   !! resolution in x and y dimensions
+    ! output fields
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: z0            !! Surface roughness
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: coastalflow   !! Diffuse flow of water into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: riverflow     !! Largest rivers flowing into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: tsol_rad      !! Radiative surface temperature
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: vevapp        !! Total of evaporation
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: temp_sol_new  !! New soil temperature
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: qsurf         !! Surface specific humidity
+    REAL(r_std),DIMENSION (iim,jjm,2), INTENT(out)          :: albedo        !! Albedo
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: fluxsens      !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: fluxlat       !! Latent chaleur flux
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(out)            :: emis          !! Emissivity
+    ! LOCAL declaration
+    ! work arrays to scatter and/or gather information just before/after sechiba_main call's
+    ! and to keep output value for next call
+    REAL(r_std),DIMENSION (kjpindex)                      :: zu            !! Work array to keep u
+    REAL(r_std),DIMENSION (kjpindex)                      :: zv            !! Work array to keep v
+    REAL(r_std),DIMENSION (kjpindex)                      :: zzlev         !! Work array to keep zlev
+    REAL(r_std),DIMENSION (kjpindex)                      :: zqair         !! Work array to keep qair
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_rain  !! Work array to keep precip_rain
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_snow  !! Work array to keep precip_snow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zlwdown       !! Work array to keep lwdown
+    REAL(r_std),DIMENSION (kjpindex)                      :: zswnet        !! Work array to keep swnet
+    REAL(r_std),DIMENSION (kjpindex)                      :: zswdown       !! Work array to keep swdown
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztemp_air     !! Work array to keep temp_air
+    REAL(r_std),DIMENSION (kjpindex)                      :: zepot_air     !! Work array to keep epot_air
+    REAL(r_std),DIMENSION (kjpindex)                      :: zccanopy      !! Work array to keep ccanopy
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpetAcoef     !! Work array to keep petAcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpeqAcoef     !! Work array to keep peqAcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpetBcoef     !! Work array to keep petBcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpeqBcoef     !! Work array to keep peqVcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcdrag        !! Work array to keep cdrag
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpb           !! Work array to keep pb
+    REAL(r_std),DIMENSION (kjpindex)                      :: zz0           !! Work array to keep z0
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcoastal      !! Work array to keep coastalflow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zriver        !! Work array to keep riverflow
+    REAL(r_std),DIMENSION (kjpindex)                      :: dcoastal      !! Work array to keep coastalflow
+    REAL(r_std),DIMENSION (kjpindex)                      :: driver        !! Work array to keep riverflow
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztsol_rad     !! Work array to keep tsol_rad
+    REAL(r_std),DIMENSION (kjpindex)                      :: zvevapp       !! Work array to keep vevapp
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztemp_sol_new !! Work array to keep temp_sol_new
+    REAL(r_std),DIMENSION (kjpindex)                      :: zqsurf        !! Work array to keep qsurf
+    REAL(r_std),DIMENSION (kjpindex,2)                    :: zalbedo       !! Work array to keep albedo
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxsens     !! Work array to keep fluxsens
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxlat      !! Work array to keep fluxlat
+    REAL(r_std),DIMENSION (kjpindex)                      :: zemis         !! Work array to keep emis
+    !
+    ! Local variables with shape of the inputs
+    !
+    REAL(r_std),DIMENSION (iim,jjm)                       :: dswnet         !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (iim,jjm)                       :: dswdown         !! Incident surface short-wave flux
+    !
+    INTEGER(i_std)                                       :: i, j, ik
+    INTEGER(i_std)                                       :: itau_sechiba
+    REAL(r_std)                                           :: zlev_mean
+    LOGICAL                                              :: do_watch      !! if it's time, write watchout
+    INTEGER                                              :: old_fileout   !! old Logical Int for std IO output
+    LOGICAL :: check = .FALSE.
+    !
+    CALL ipslnlf(new_number=numout,old_number=old_fileout)
+    !
+    IF (l_first_intersurf) THEN
+!       CALL Init_WriteField_p(kindex)
+       !
+       CALL intsurf_time( kjit, date0, xrdt )
+       !
+       IF ( check ) WRITE(numout,*) 'Initialisation of intersurf_main_2d'
+       !
+       OFF_LINE_MODE = .TRUE. 
+       !
+       DO ik=1,kjpindex
+          
+          j = ((kindex(ik)-1)/iim) + 1
+          i = (kindex(ik) - (j-1)*iim)
+
+          !- Create the internal coordinate table
+          !-
+          lalo(ik,1) = lat(i,j)
+          lalo(ik,2) = lon(i,j)
+          !
+          !- Store the fraction of the continents only once so that the user
+          !- does not change them afterwards.
+          !-
+          contfrac(ik) = zcontfrac(i,j)
+       ENDDO
+       CALL gather(contfrac,contfrac_g)
+       CALL gather(lalo,lalo_g)
+       CALL gather2D(lon,lon_g)
+       CALL gather2D(lat,lat_g)
+       CALL gather2D(zlev,zlev_g)
+       !
+       !  Configuration of SSL specific parameters
+       !
+       CALL intsurf_config(control_flags, xrdt)
+       !
+       CALL intsurf_restart(kjit, iim, jjm, lon, lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
+       itau_sechiba = kjit + itau_offset
+       !
+       CALL intsurf_history(iim, jjm, lon, lat, itau_sechiba, date0_shifted, xrdt, control_flags, hist_id, &
+            & hist2_id, hist_id_stom, hist_id_stom_IPCC)
+       !
+       IF ( ok_watchout ) THEN
+          IF (is_root_prc) THEN
+             zlev_mean = zero
+             DO ik=1, nbp_glo
+                j = ((index_g(ik)-1)/iim_g) + 1
+                i = (index_g(ik) - (j-1)*iim_g)
+       
+                zlev_mean = zlev_mean + zlev_g(i,j)
+             ENDDO
+             zlev_mean = zlev_mean / REAL(nbp_glo,r_std)
+          ENDIF
+
+          last_action_watch = itau_sechiba
+          last_check_watch  = last_action_watch
+
+          ! Only root proc write watchout file
+          CALL watchout_init (iim_g, jjm_g, kjpindex, nbp_glo, &
+               & date0_shifted, last_action_watch, dt_watch, index_g, lon_g, lat_g, zlev_mean)
+       ENDIF
+       !
+       IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
+       !
+    ENDIF
+    !
+    !  Shift the time step to phase the two models
+    !
+    itau_sechiba = kjit + itau_offset
+    !
+    CALL intsurf_time( itau_sechiba, date0_shifted, xrdt )
+    !
+    ! 1. gather input fields from kindex array
+    !    Warning : I'm not sure this interface with one dimension array is the good one
+    !
+    DO ik=1, kjpindex
+      
+       j = ((kindex(ik)-1)/iim) + 1
+       i = (kindex(ik) - (j-1)*iim)
+       
+       zu(ik)           = u(i,j)
+       zv(ik)           = v(i,j)
+       zzlev(ik)        = zlev(i,j)
+       zqair(ik)        = qair(i,j)
+       zprecip_rain(ik) = precip_rain(i,j)*xrdt
+       zprecip_snow(ik) = precip_snow(i,j)*xrdt
+       zlwdown(ik)      = lwdown(i,j)
+       zswnet(ik)       = swnet(i,j)
+       zswdown(ik)      = swdown(i,j)
+       ztemp_air(ik)    = temp_air(i,j)
+       zepot_air(ik)    = epot_air(i,j)
+       zccanopy(ik)     = ccanopy(i,j)
+       zpetAcoef(ik)    = petAcoef(i,j)
+       zpeqAcoef(ik)    = peqAcoef(i,j)
+       zpetBcoef(ik)    = petBcoef(i,j)
+       zpeqBcoef(ik)    = peqBcoef(i,j)
+       zcdrag(ik)       = cdrag(i,j)
+       zpb(ik)          = pb(i,j)
+       
+    ENDDO
+    !
+    IF (check_INPUTS) THEN
+       WRITE(numout,*) "Intersurf_main_2D :"
+       WRITE(numout,*) "Time step number = ",kjit
+       WRITE(numout,*) "Dimension of input fields = ",iim, jjm
+       WRITE(numout,*) "Number of continental points = ",kjpindex
+       WRITE(numout,*) "Time step in seconds = ",xrdt
+       WRITE(numout,*) "Logical for _restart_ file to read, write = ",lrestart_read,lrestart_write
+       WRITE(numout,*) "Date at which kjit = 0  =  ",date0
+       WRITE(numout,*) "Index for continental points = ",kindex
+       WRITE(numout,*) "Lowest level wind speed North = ",zu
+       WRITE(numout,*) "Lowest level wind speed East = ",zv
+       WRITE(numout,*) "Height of first layer = ",zzlev
+       WRITE(numout,*) "Lowest level specific humidity = ",zqair
+       WRITE(numout,*) "Rain precipitation = ",zprecip_rain
+       WRITE(numout,*) "Snow precipitation = ",zprecip_snow
+       WRITE(numout,*) "Down-welling long-wave flux = ",zlwdown
+       WRITE(numout,*) "Net surface short-wave flux = ",zswnet
+       WRITE(numout,*) "Downwelling surface short-wave flux = ",zswdown
+       WRITE(numout,*) "Air temperature in Kelvin = ",ztemp_air
+       WRITE(numout,*) "Air potential energy = ",zepot_air
+       WRITE(numout,*) "CO2 concentration in the canopy = ",zccanopy
+       WRITE(numout,*) "Coeficients A from the PBL resolution = ",zpetAcoef
+       WRITE(numout,*) "One for T and another for q = ",zpeqAcoef
+       WRITE(numout,*) "Coeficients B from the PBL resolution = ",zpetBcoef
+       WRITE(numout,*) "One for T and another for q = ",zpeqBcoef
+       WRITE(numout,*) "Cdrag = ",zcdrag
+       WRITE(numout,*) "Lowest level pressure = ",zpb
+       WRITE(numout,*) "Geographical coordinates lon = ", (/ ( lon(ilandindex(ik), jlandindex(ik)), ik=1,kjpindex ) /)
+       WRITE(numout,*) "Geographical coordinates lat = ", (/ ( lat(ilandindex(ik), jlandindex(ik)), ik=1,kjpindex ) /) 
+       WRITE(numout,*) "Fraction of continent in the grid = ",contfrac
+    ENDIF
+    !
+    ! 2. save the grid
+    !
+    IF ( check ) WRITE(numout,*) 'Save the grid'
+    !
+    IF (l_first_intersurf) THEN
+       CALL histwrite(hist_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+       CALL histwrite(hist_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histwrite(hist_id_stom, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          IF ( hist_id_stom_IPCC > 0 ) THEN
+             CALL histwrite(hist_id_stom_IPCC, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          ENDIF
+       ENDIF
+       CALL histwrite(hist_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       CALL histsync(hist_id)
+       !
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+          CALL histsync(hist2_id)
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 3. call sechiba for continental points only
+    !
+    IF ( check ) WRITE(numout,*) 'Calling sechiba'
+    !
+    CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
+       & lrestart_read, lrestart_write, control_flags, &
+       & lalo, contfrac, neighbours, resolution, &
+! First level conditions
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
+!       & zzlev, zu, zv, zqair, ztemp_air, zepot_air, zccanopy, &
+       & zzlev, zu, zv, zqair, zqair, ztemp_air, ztemp_air, zepot_air, zccanopy, &
+! Variables for the implicit coupling
+       & zcdrag, zpetAcoef, zpeqAcoef, zpetBcoef, zpeqBcoef, &
+! Rain, snow, radiation and surface pressure
+       & zprecip_rain ,zprecip_snow,  zlwdown, zswnet, zswdown, zpb, &
+! Output : Fluxes
+       & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
+! Surface temperatures and surface properties
+       & ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
+! File ids
+       & rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC ) 
+    
+    !
+    IF ( check ) WRITE(numout,*) 'out of SECHIBA'
+    !
+    ! 4. save watchout
+    !
+    IF ( ok_watchout .AND. .NOT. l_first_intersurf ) THEN
+       ! Accumulate last time step
+       sum_zlev(:) = sum_zlev(:) + zzlev(:)
+       sum_u(:) = sum_u(:) + zu(:)
+       sum_v(:) = sum_v(:) + zv(:)
+       sum_qair(:) = sum_qair(:) + zqair(:) 
+       sum_temp_air(:) = sum_temp_air(:) + ztemp_air(:)
+       sum_epot_air(:) = sum_epot_air(:) + zepot_air(:)
+       sum_ccanopy(:) = sum_ccanopy(:) + zccanopy(:)
+       sum_cdrag(:) = sum_cdrag(:) + zcdrag(:)
+       sum_petAcoef(:) = sum_petAcoef(:) + zpetAcoef(:)
+       sum_peqAcoef(:) = sum_peqAcoef(:) + zpeqAcoef(:)
+       sum_petBcoef(:) = sum_petBcoef(:) + zpetBcoef(:)
+       sum_peqBcoef(:) = sum_peqBcoef(:) + zpeqBcoef(:)
+       sum_rain(:) = sum_rain(:) + zprecip_rain(:)
+       sum_snow(:) = sum_snow(:) + zprecip_snow(:)
+       sum_lwdown(:) = sum_lwdown(:) + zlwdown(:)
+       sum_pb(:) = sum_pb(:) + zpb(:)
+
+!!$       IF ( dt_watch > 3600 ) THEN
+!!$          julian_watch = date0_shifted+((itau_sechiba-0.5)/dt_split_watch)*dt_watch/one_day
+!!$          WRITE(numout, *) "WATCH register : julian_watch ",julian_watch, " julian0",julian0,"date0_shifted ",date0_shifted, &
+!!$               "itau_sechiba ",itau_sechiba, &
+!!$               dt_split_watch,dt_watch,one_day
+!!$          CALL solarang (julian_watch, julian0, iim, jjm, lon, lat, sinang)
+!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) ) 
+!!$             isinang(:,:) = isinang(:,:) - 1
+!!$          ENDWHERE
+!!$          mean_sinang(:,:) = mean_sinang(:,:)+sinang(:,:)
+!!$          WRITE(numout, *) "WATCH sinang : ",sinang, mean_sinang
+!!$          WRITE(numout,*) "sum_swdown",sum_swdown
+!!$          !
+!!$          DO ik=1,kjpindex          
+!!$             j = ((kindex(ik)-1)/iim) + 1
+!!$             i = (kindex(ik) - (j-1)*iim)
+!!$             
+!!$             sum_swnet(ik) = sum_swnet(ik) + sinang(i,j)*zswnet(ik)
+!!$             sum_swdown(ik) = sum_swdown(ik) + sinang(i,j)*zswdown(ik)
+!!$          ENDDO
+!!$       ELSE
+          sum_swnet(:) = sum_swnet(:) + zswnet(:)
+          sum_swdown(:) = sum_swdown(:) + zswdown(:)
+!!$       ENDIF
+
+       do_watch = .FALSE.
+       call isittime &
+            &  (itau_sechiba,date0_shifted,xrdt,dt_watch,&
+            &   last_action_watch,last_check_watch,do_watch)
+       last_check_watch = itau_sechiba
+       IF (do_watch) THEN
+          !
+          IF ( check ) WRITE(numout,*) 'save watchout'
+          !
+          IF (long_print) THEN
+             WRITE(numout,*) "intersurf : write watchout for date ",date0,date0_shifted,itau_sechiba,&
+                  & last_action_watch, last_check_watch
+          ENDIF
+          last_action_watch = itau_sechiba
+
+          sum_zlev(:) = sum_zlev(:) / dt_split_watch
+          sum_u(:) = sum_u(:) / dt_split_watch
+          sum_v(:) = sum_v(:) / dt_split_watch
+          sum_qair(:) = sum_qair(:) / dt_split_watch
+          sum_temp_air(:) = sum_temp_air(:) / dt_split_watch
+          sum_epot_air(:) = sum_epot_air(:) / dt_split_watch
+          sum_ccanopy(:) = sum_ccanopy(:) / dt_split_watch
+          sum_cdrag(:) = sum_cdrag(:) / dt_split_watch
+          sum_petAcoef(:) = sum_petAcoef(:) / dt_split_watch
+          sum_peqAcoef(:) = sum_peqAcoef(:) / dt_split_watch
+          sum_petBcoef(:) = sum_petBcoef(:) / dt_split_watch
+          sum_peqBcoef(:) = sum_peqBcoef(:) / dt_split_watch
+          sum_rain(:) = sum_rain(:) / dt_split_watch
+          sum_snow(:) = sum_snow(:) / dt_split_watch
+          sum_lwdown(:) = sum_lwdown(:) / dt_split_watch
+          sum_pb(:) = sum_pb(:) / dt_split_watch
+
+!!$          IF ( dt_watch > 3600 ) THEN 
+!!$             WRITE(numout, *) "WATCH mean_sinang before norm : ",mean_sinang,isinang
+!!$             WHERE ( isinang(:,:) .LT. dt_split_watch )
+!!$                mean_sinang(:,:) = mean_sinang(:,:) / isinang(:,:)
+!!$             ENDWHERE
+!!$             WRITE(numout, *) "WATCH mean_sinang norm : ",mean_sinang
+!!$             WRITE(numout,*) "SWDOWN 0 : ",sum_swdown(:)
+!!$             !
+!!$             DO ik=1,kjpindex          
+!!$                j = ((kindex(ik)-1)/iim) + 1
+!!$                i = (kindex(ik) - (j-1)*iim)
+!!$                IF (mean_sinang(i,j) > zero) THEN
+!!$                   sum_swdown(ik) = sum_swdown(ik)/mean_sinang(i,j)
+!!$                   sum_swnet(ik) =  sum_swnet(ik)/mean_sinang(i,j)
+!!$                ELSE
+!!$                   sum_swdown(ik) = zero
+!!$                   sum_swnet(ik) =  zero
+!!$                ENDIF
+!!$             ENDDO
+!!$          ELSE
+             sum_swnet(:) = sum_swnet(:) / dt_split_watch
+             sum_swdown(:) = sum_swdown(:) / dt_split_watch
+!!$          ENDIF
+
+          CALL watchout_write_p(kjpindex, itau_sechiba, xrdt, sum_zlev, sum_swdown, sum_rain, &
+               &   sum_snow, sum_lwdown, sum_pb, sum_temp_air, sum_epot_air, sum_qair, &
+               &   sum_u, sum_v, sum_swnet, sum_petAcoef, sum_peqAcoef, sum_petBcoef, sum_peqBcoef, &
+               &   sum_cdrag, sum_ccanopy )
+       ENDIF
+    ENDIF
+    !
+    ! 5. scatter output fields
+    !
+    z0(:,:)           = undef_sechiba
+    coastalflow(:,:)  = undef_sechiba
+    riverflow(:,:)    = undef_sechiba
+    tsol_rad(:,:)     = undef_sechiba
+    vevapp(:,:)       = undef_sechiba
+    temp_sol_new(:,:) = undef_sechiba 
+    qsurf(:,:)        = undef_sechiba 
+    albedo(:,:,:)     = undef_sechiba
+    fluxsens(:,:)     = undef_sechiba
+    fluxlat(:,:)      = undef_sechiba
+    emis(:,:)         = undef_sechiba 
+    cdrag(:,:)        = undef_sechiba 
+    dswnet(:,:)       = undef_sechiba 
+    dswdown(:,:)      = undef_sechiba 
+    !
+    DO ik=1, kjpindex
+      
+    
+       j = ((kindex(ik)-1)/iim) + 1
+       i = (kindex(ik) - (j-1)*iim)
+
+       z0(i,j)           = zz0(ik)
+       coastalflow(i,j)  = zcoastal(ik)/1000.
+       riverflow(i,j)    = zriver(ik)/1000.
+       tsol_rad(i,j)     = ztsol_rad(ik)
+       vevapp(i,j)       = zvevapp(ik)
+       temp_sol_new(i,j) = ztemp_sol_new(ik)
+       qsurf(i,j)        = zqsurf(ik)
+       albedo(i,j,1)     = zalbedo(ik,1)
+       albedo(i,j,2)     = zalbedo(ik,2)
+       fluxsens(i,j)     = zfluxsens(ik)
+       fluxlat(i,j)      = zfluxlat(ik)
+       emis(i,j)         = zemis(ik)
+       cdrag(i,j)        = zcdrag(ik)
+       dswnet(i,j)       = zswnet(ik)
+       dswdown(i,j)      = zswdown(ik)
+
+    ENDDO
+    !
+    ! Modified fields for variables scattered during the writing
+    !
+    dcoastal(:) = (zcoastal(:))/1000.     
+    driver(:)   = (zriver(:))/1000.
+    !
+    IF ( .NOT. l_first_intersurf) THEN
+       !
+       IF ( .NOT. almaoutput ) THEN
+       !
+       !  scattered during the writing
+       !
+          CALL histwrite (hist_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+       ! 
+          CALL histwrite (hist_id, 'temp_sol', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+          CALL histwrite (hist_id, 'tsol_max', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+          CALL histwrite (hist_id, 'tsol_min', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+          CALL histwrite (hist_id, 'fluxsens', itau_sechiba, fluxsens, kjpindex, kindex)
+          CALL histwrite (hist_id, 'fluxlat',  itau_sechiba, fluxlat, kjpindex, kindex)
+          CALL histwrite (hist_id, 'swnet',    itau_sechiba, dswnet, kjpindex, kindex)
+          CALL histwrite (hist_id, 'swdown',   itau_sechiba, dswdown, kjpindex, kindex)
+          CALL histwrite (hist_id, 'alb_vis',  itau_sechiba, albedo(:,:,1), kjpindex, kindex)
+          CALL histwrite (hist_id, 'alb_nir',  itau_sechiba, albedo(:,:,2), kjpindex, kindex)
+          CALL histwrite (hist_id, 'tair',     itau_sechiba, temp_air, kjpindex, kindex)
+          CALL histwrite (hist_id, 'qair',     itau_sechiba, qair, kjpindex, kindex)
+          ! Ajout Nathalie - Juin 2006 - on conserve q2m/t2m
+          CALL histwrite (hist_id, 'q2m',     itau_sechiba, qair, kjpindex, kindex)
+          CALL histwrite (hist_id, 't2m',     itau_sechiba, temp_air, kjpindex, kindex)
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+             ! 
+             CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, fluxsens, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'fluxlat',  itau_sechiba, fluxlat, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'swnet',    itau_sechiba, dswnet, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'swdown',   itau_sechiba, dswdown, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'alb_vis',  itau_sechiba, albedo(:,:,1), kjpindex, kindex)
+             CALL histwrite (hist2_id, 'alb_nir',  itau_sechiba, albedo(:,:,2), kjpindex, kindex)
+             CALL histwrite (hist2_id, 'tair',     itau_sechiba, temp_air, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'qair',     itau_sechiba, qair, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'q2m',     itau_sechiba, qair, kjpindex, kindex)
+             CALL histwrite (hist2_id, 't2m',     itau_sechiba, temp_air, kjpindex, kindex)
+          ENDIF
+       ELSE
+          CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'SWnet',    itau_sechiba, dswnet, kjpindex, kindex)
+          CALL histwrite (hist_id, 'Qh', itau_sechiba, fluxsens, kjpindex, kindex)
+          CALL histwrite (hist_id, 'Qle',  itau_sechiba, fluxlat, kjpindex, kindex)
+          CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+          CALL histwrite (hist_id, 'RadT', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'SWnet',    itau_sechiba, dswnet, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'Qh', itau_sechiba, fluxsens, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'Qle',  itau_sechiba, fluxlat, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'RadT', itau_sechiba, temp_sol_NEW, kjpindex, kindex)
+          ENDIF
+       ENDIF
+       !
+       IF (dw .EQ. xrdt) THEN
+          CALL histsync(hist_id)
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 6. Transform the water fluxes into Kg/m^2s and m^3/s
+    !
+    DO ik=1, kjpindex
+    
+       j = ((kindex(ik)-1)/iim) + 1
+       i = (kindex(ik) - (j-1)*iim)
+
+       vevapp(i,j) = vevapp(i,j)/xrdt
+       coastalflow(i,j) = coastalflow(i,j)/xrdt
+       riverflow(i,j) = riverflow(i,j)/xrdt
+
+    ENDDO
+    !
+    IF ( lrestart_write .AND. ok_watchout .AND. is_root_prc ) THEN
+       CALL watchout_close()
+    ENDIF
+    !
+    IF(l_first_intersurf .AND. is_root_prc) CALL getin_dump
+    l_first_intersurf = .FALSE.
+    !
+    IF (long_print) WRITE (numout,*) ' intersurf_main done '
+    !
+    CALL ipslnlf(new_number=old_fileout)
+    !
+  END SUBROUTINE intersurf_main_2d
+!
+  SUBROUTINE intersurf_main_1d (kjit, iim, jjm, kjpindex, kindex, xrdt, &
+     & lrestart_read, lrestart_write, lon, lat, zcontfrac, zneighbours, zresolution, date0, &
+! First level conditions
+     & zlev,  u, v, qair, temp_air, epot_air, ccanopy, &
+! Variables for the implicit coupling
+     & cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+     & precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+     & vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
+! Surface temperatures and surface properties
+     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0) 
+    
+    ! routines called : sechiba_main
+    !
+    IMPLICIT NONE
+    !    
+    ! interface description for dummy arguments
+    ! input scalar 
+    INTEGER(i_std),INTENT (in)                            :: kjit          !! Time step number
+    INTEGER(i_std),INTENT (in)                            :: iim, jjm      !! Dimension of input fields
+    INTEGER(i_std),INTENT (in)                            :: kjpindex      !! Number of continental points
+    REAL(r_std),INTENT (in)                               :: xrdt          !! Time step in seconds
+    LOGICAL, INTENT (in)                                 :: lrestart_read !! Logical for _restart_ file to read
+    LOGICAL, INTENT (in)                                 :: lrestart_write!! Logical for _restart_ file to write'
+    REAL(r_std), INTENT (in)                              :: date0         !! Date at which kjit = 0
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)      :: kindex        !! Index for continental points
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: u             !! Lowest level wind speed
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: v             !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: zlev          !! Height of first layer
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: qair          !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: precip_rain   !! Rain precipitation
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: precip_snow   !! Snow precipitation
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: lwdown        !! Down-welling long-wave flux 
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: swnet         !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: swdown        !! Downwelling surface short-wave flux
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: temp_air      !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: epot_air      !! Air potential energy
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: ccanopy       !! CO2 concentration in the canopy
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: petAcoef      !! Coeficients A from the PBL resolution
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: peqAcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: petBcoef      !! Coeficients B from the PBL resolution
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: peqBcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(inout)          :: cdrag         !! Cdrag
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: pb            !! Lowest level pressure
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: lon, lat      !! Geographical coordinates
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(in)             :: zcontfrac     !! Fraction of continent
+    INTEGER, DIMENSION (iim*jjm,8), INTENT(in)             :: zneighbours   !! land neighbours
+    REAL(r_std),DIMENSION (iim*jjm,2), INTENT(in)           :: zresolution   !! resolution in x and y dimensions
+    ! output fields
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: z0            !! Surface roughness
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: coastalflow   !! Diffuse flow of water into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: riverflow     !! Largest rivers flowing into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: tsol_rad      !! Radiative surface temperature
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: vevapp        !! Total of evaporation
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: temp_sol_new  !! New soil temperature
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: qsurf         !! Surface specific humidity
+    REAL(r_std),DIMENSION (iim*jjm,2), INTENT(out)          :: albedo        !! Albedo
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: fluxsens      !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: fluxlat       !! Latent chaleur flux
+    REAL(r_std),DIMENSION (iim*jjm), INTENT(out)            :: emis          !! Emissivity
+    ! LOCAL declaration
+    ! work arrays to scatter and/or gather information just before/after sechiba_main call's
+    ! and to keep output value for next call
+    REAL(r_std),DIMENSION (kjpindex)                      :: zu            !! Work array to keep u
+    REAL(r_std),DIMENSION (kjpindex)                      :: zv            !! Work array to keep v
+    REAL(r_std),DIMENSION (kjpindex)                      :: zzlev         !! Work array to keep zlev
+    REAL(r_std),DIMENSION (kjpindex)                      :: zqair         !! Work array to keep qair
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_rain  !! Work array to keep precip_rain
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_snow  !! Work array to keep precip_snow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zlwdown       !! Work array to keep lwdown
+    REAL(r_std),DIMENSION (kjpindex)                      :: zswnet        !! Work array to keep swnet
+    REAL(r_std),DIMENSION (kjpindex)                      :: zswdown       !! Work array to keep swdown
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztemp_air     !! Work array to keep temp_air
+    REAL(r_std),DIMENSION (kjpindex)                      :: zepot_air     !! Work array to keep epot_air
+    REAL(r_std),DIMENSION (kjpindex)                      :: zccanopy      !! Work array to keep ccanopy
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpetAcoef     !! Work array to keep petAcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpeqAcoef     !! Work array to keep peqAcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpetBcoef     !! Work array to keep petBcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpeqBcoef     !! Work array to keep peqVcoef
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcdrag        !! Work array to keep cdrag
+    REAL(r_std),DIMENSION (kjpindex)                      :: zpb           !! Work array to keep pb
+    REAL(r_std),DIMENSION (kjpindex)                      :: zz0           !! Work array to keep z0
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcoastal      !! Work array to keep coastal flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zriver        !! Work array to keep river out flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: dcoastal      !! Work array to keep coastal flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: driver        !! Work array to keep river out flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztsol_rad     !! Work array to keep tsol_rad
+    REAL(r_std),DIMENSION (kjpindex)                      :: zvevapp       !! Work array to keep vevapp
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztemp_sol_new !! Work array to keep temp_sol_new
+    REAL(r_std),DIMENSION (kjpindex)                      :: zqsurf        !! Work array to keep qsurf
+    REAL(r_std),DIMENSION (kjpindex,2)                    :: zalbedo       !! Work array to keep albedo
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxsens     !! Work array to keep fluxsens
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxlat      !! Work array to keep fluxlat
+    REAL(r_std),DIMENSION (kjpindex)                      :: zemis         !! Work array to keep emis
+    !
+    ! Local but with input shape
+    !
+    REAL(r_std),DIMENSION (iim*jjm)                       :: dswnet         !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (iim*jjm)                       :: dswdown        !! Incident surface short-wave flux
+    !
+    INTEGER(i_std)                                        :: i, j, ik
+    INTEGER(i_std)                                        :: itau_sechiba
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)              :: tmp_lon, tmp_lat, tmp_lev
+    REAL(r_std)                                           :: zlev_mean
+    LOGICAL                                               :: do_watch      !! if it's time, write watchout
+    INTEGER                                               :: old_fileout   !! old Logical Int for std IO output
+    LOGICAL :: check = .FALSE.
+    !
+    CALL ipslnlf(new_number=numout,old_number=old_fileout)
+    !
+    IF (l_first_intersurf) THEN
+       !
+       CALL intsurf_time( kjit, date0, xrdt )
+       !
+       IF ( check ) WRITE(numout,*) 'Initialisation of intersurf_main_1d'
+       !
+       OFF_LINE_MODE = .TRUE. 
+       !
+       !  Create the internal coordinate table
+       !
+       IF ( (.NOT.ALLOCATED(tmp_lon))) THEN
+          ALLOCATE(tmp_lon(iim,jjm))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lat))) THEN
+          ALLOCATE(tmp_lat(iim,jjm))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lev))) THEN
+          ALLOCATE(tmp_lev(iim,jjm))
+       ENDIF
+       !
+       DO i=1,iim
+          DO j=1,jjm
+             ik = (j-1)*iim + i
+             tmp_lon(i,j) = lon(ik)
+             tmp_lat(i,j) = lat(ik)
+             tmp_lev(i,j) = zlev(kindex(ik)) 
+          ENDDO
+       ENDDO
+       !
+       lalo(:,1) = lat(:)
+       lalo(:,2) = lon(:)
+       !
+       !- Store the fraction of the continents only once so that the user
+       !- does not change them afterwards.
+       !
+       DO ik=1,kjpindex
+
+          contfrac(ik) = zcontfrac(kindex(ik))
+
+       ENDDO
+       contfrac_g(:) = contfrac(:)
+       lalo_g(:,:) = lalo(:,:)
+       lon_g(:,:) = tmp_lon(:,:)
+       lat_g(:,:) = tmp_lat(:,:)
+       zlev_g(:,:) = tmp_lev(:,:)
+       !
+       !  Configuration of SSL specific parameters
+       !
+       CALL intsurf_config(control_flags, xrdt)
+       !
+       CALL intsurf_restart(kjit, iim, jjm, tmp_lon, tmp_lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
+       itau_sechiba = kjit + itau_offset
+       !
+       CALL intsurf_history(iim, jjm, tmp_lon, tmp_lat, itau_sechiba, date0_shifted, xrdt, control_flags, hist_id, &
+            & hist2_id, hist_id_stom, hist_id_stom_IPCC)
+       !
+       IF ( ok_watchout ) THEN
+          zlev_mean = zero
+          DO ik=1, kjpindex
+
+             zlev_mean = zlev_mean + zlev(ik)
+          ENDDO
+          ! Divide by one
+          zlev_mean = zlev_mean / REAL(kjpindex,r_std)
+
+          last_action_watch = itau_sechiba
+          last_check_watch  = last_action_watch
+
+          CALL watchout_init(iim, jjm, kjpindex, kjpindex, &
+               & date0_shifted, last_action_watch, dt_watch, index_g, lon_g, lat_g, zlev_mean)
+       ENDIF
+       !
+       IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
+       !
+    ENDIF
+    !
+    !  Shift the time step to phase the two models
+    !
+    itau_sechiba = kjit + itau_offset
+    !
+    CALL intsurf_time( itau_sechiba, date0_shifted, xrdt )
+    !
+    ! 1. gather input fields from kindex array
+    !
+    DO ik=1, kjpindex
+       
+       zu(ik)           = u(kindex(ik))
+       zv(ik)           = v(kindex(ik))
+       zzlev(ik)        = zlev(kindex(ik))
+       zqair(ik)        = qair(kindex(ik))
+       zprecip_rain(ik) = precip_rain(kindex(ik))*xrdt
+       zprecip_snow(ik) = precip_snow(kindex(ik))*xrdt
+       zlwdown(ik)      = lwdown(kindex(ik))
+       zswnet(ik)       = swnet(kindex(ik))
+       zswdown(ik)      = swdown(kindex(ik))
+       ztemp_air(ik)    = temp_air(kindex(ik))
+       zepot_air(ik)    = epot_air(kindex(ik))
+       zccanopy(ik)     = ccanopy(kindex(ik))
+       zpetAcoef(ik)    = petAcoef(kindex(ik))
+       zpeqAcoef(ik)    = peqAcoef(kindex(ik))
+       zpetBcoef(ik)    = petBcoef(kindex(ik))
+       zpeqBcoef(ik)    = peqBcoef(kindex(ik))
+       zcdrag(ik)       = cdrag(kindex(ik))
+       zpb(ik)          = pb(kindex(ik))
+       
+    ENDDO
+    !
+    ! 2. save the grid
+    !
+    IF ( check ) WRITE(numout,*) 'Save the grid'
+    !
+    IF (l_first_intersurf) THEN
+       !
+       CALL histwrite(hist_id, 'LandPoints',  itau_sechiba+1, (/ REAL(kindex) /), kjpindex, kindex)
+       CALL histwrite(hist_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histwrite(hist_id_stom, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          IF ( hist_id_stom_IPCC > 0 ) THEN
+             CALL histwrite(hist_id_stom_IPCC, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          ENDIF
+       ENDIF
+       CALL histwrite(hist_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       CALL histsync(hist_id)
+       !
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'LandPoints',  itau_sechiba+1, (/ REAL(kindex) /), kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+          CALL histsync(hist2_id)
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 3. call sechiba
+    !
+    IF ( check ) WRITE(numout,*) 'Calling sechiba'
+    !
+    CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
+       & lrestart_read, lrestart_write, control_flags, &
+       & lalo, contfrac, neighbours, resolution, &
+! First level conditions
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
+!       & zzlev, zu, zv, zqair, ztemp_air, zepot_air, zccanopy, &
+       & zzlev, zu, zv, zqair, zqair, ztemp_air, ztemp_air, zepot_air, zccanopy, &
+! Variables for the implicit coupling
+       & zcdrag, zpetAcoef, zpeqAcoef, zpetBcoef, zpeqBcoef, &
+! Rain, snow, radiation and surface pressure
+       & zprecip_rain ,zprecip_snow,  zlwdown, zswnet, zswdown, zpb, &
+! Output : Fluxes
+       & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
+! Surface temperatures and surface properties
+       & ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
+! File ids
+       & rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC ) 
+    
+    !
+    IF ( check ) WRITE(numout,*) 'out of SECHIBA'
+    !
+    ! 4. save watchout
+    !
+    IF ( ok_watchout .AND. .NOT. l_first_intersurf ) THEN
+       ! Accumulate last time step
+       sum_zlev(:) = sum_zlev(:) + zzlev(:)
+       sum_u(:) = sum_u(:) + zu(:)
+       sum_v(:) = sum_v(:) + zv(:)
+       sum_qair(:) = sum_qair(:) + zqair(:) 
+       sum_temp_air(:) = sum_temp_air(:) + ztemp_air(:)
+       sum_epot_air(:) = sum_epot_air(:) + zepot_air(:)
+       sum_ccanopy(:) = sum_ccanopy(:) + zccanopy(:)
+       sum_cdrag(:) = sum_cdrag(:) + zcdrag(:)
+       sum_petAcoef(:) = sum_petAcoef(:) + zpetAcoef(:)
+       sum_peqAcoef(:) = sum_peqAcoef(:) + zpeqAcoef(:)
+       sum_petBcoef(:) = sum_petBcoef(:) + zpetBcoef(:)
+       sum_peqBcoef(:) = sum_peqBcoef(:) + zpeqBcoef(:)
+       sum_rain(:) = sum_rain(:) + zprecip_rain(:)
+       sum_snow(:) = sum_snow(:) + zprecip_snow(:)
+       sum_lwdown(:) = sum_lwdown(:) + zlwdown(:)
+       sum_pb(:) = sum_pb(:) + zpb(:)
+       
+!!$       IF ( dt_watch > 3600 ) THEN
+!!$          julian_watch = date0_shifted+((itau_sechiba-0.5)/dt_split_watch)*dt_watch/one_day
+!!$          CALL solarang (julian_watch, julian0, iim, jjm, lon, lat, sinang)
+!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) ) 
+!!$             isinang(:,:) = isinang(:,:) - 1
+!!$          ENDWHERE
+!!$          mean_sinang(:,:) = mean_sinang(:,:)+sinang(:,:)
+!!$          !
+!!$          DO ik=1,kjpindex          
+!!$             j = ((kindex(ik)-1)/iim) + 1
+!!$             i = (kindex(ik) - (j-1)*iim)
+!!$             
+!!$             sum_swnet(ik) = sum_swnet(ik) + sinang(i,j)*zswnet(ik)
+!!$             sum_swdown(ik) = sum_swdown(ik) + sinang(i,j)*zswdown(ik)
+!!$          ENDDO
+!!$       ELSE
+          sum_swnet(:) = sum_swnet(:) + zswnet(:)
+          sum_swdown(:) = sum_swdown(:) + zswdown(:)
+!!$       ENDIF
+          
+       do_watch = .FALSE.
+       call isittime &
+            &  (itau_sechiba,date0_shifted,xrdt,dt_watch,&
+            &   last_action_watch,last_check_watch,do_watch)
+       last_check_watch = itau_sechiba
+       IF (do_watch) THEN
+          !
+          IF ( check ) WRITE(numout,*) 'save watchout'
+          !
+          IF (long_print) THEN
+             WRITE(numout,*) "intersurf : write watchout for date ",date0,date0_shifted,itau_sechiba,&
+                  & last_action_watch, last_check_watch
+          ENDIF
+          last_action_watch = itau_sechiba
+
+          sum_zlev(:) = sum_zlev(:) / dt_split_watch
+          sum_u(:) = sum_u(:) / dt_split_watch
+          sum_v(:) = sum_v(:) / dt_split_watch
+          sum_qair(:) = sum_qair(:) / dt_split_watch
+          sum_temp_air(:) = sum_temp_air(:) / dt_split_watch
+          sum_epot_air(:) = sum_epot_air(:) / dt_split_watch
+          sum_ccanopy(:) = sum_ccanopy(:) / dt_split_watch
+          sum_cdrag(:) = sum_cdrag(:) / dt_split_watch
+          sum_petAcoef(:) = sum_petAcoef(:) / dt_split_watch
+          sum_peqAcoef(:) = sum_peqAcoef(:) / dt_split_watch
+          sum_petBcoef(:) = sum_petBcoef(:) / dt_split_watch
+          sum_peqBcoef(:) = sum_peqBcoef(:) / dt_split_watch
+          sum_rain(:) = sum_rain(:) / dt_split_watch
+          sum_snow(:) = sum_snow(:) / dt_split_watch
+          sum_lwdown(:) = sum_lwdown(:) / dt_split_watch
+          sum_pb(:) = sum_pb(:) / dt_split_watch
+
+!!$          IF ( dt_watch > 3600 ) THEN 
+!!$             WHERE ( isinang(:,:) .GT. 0 )
+!!$                mean_sinang(:,:) = mean_sinang(:,:) / isinang(:,:)
+!!$             ENDWHERE
+!!$             !
+!!$             DO ik=1,kjpindex          
+!!$                j = ((kindex(ik)-1)/iim) + 1
+!!$                i = (kindex(ik) - (j-1)*iim)
+!!$                IF (mean_sinang(i,j) > zero) THEN
+!!$                   sum_swdown(ik) = sum_swdown(ik)/mean_sinang(i,j)
+!!$                   sum_swnet(ik) =  sum_swnet(ik)/mean_sinang(i,j)
+!!$                ELSE
+!!$                   sum_swdown(ik) = zero
+!!$                   sum_swnet(ik) =  zero
+!!$                ENDIF
+!!$             ENDDO
+!!$          ELSE
+             sum_swnet(:) = sum_swnet(:) / dt_split_watch
+             sum_swdown(:) = sum_swdown(:) / dt_split_watch
+!!$          ENDIF
+
+          CALL watchout_write_p(kjpindex, itau_sechiba, xrdt, sum_zlev, sum_swdown, sum_rain, &
+               &   sum_snow, sum_lwdown, sum_pb, sum_temp_air, sum_epot_air, sum_qair, &
+               &   sum_u, sum_v, sum_swnet, sum_petAcoef, sum_peqAcoef, sum_petBcoef, sum_peqBcoef, &
+               &   sum_cdrag, sum_ccanopy )
+       ENDIF
+    ENDIF
+    !
+    ! 5. scatter output fields
+    !
+    !
+    z0(:)           = undef_sechiba
+    coastalflow(:)  = undef_sechiba
+    riverflow(:)    = undef_sechiba
+    tsol_rad(:)     = undef_sechiba
+    vevapp(:)       = undef_sechiba
+    temp_sol_new(:) = undef_sechiba 
+    qsurf(:)        = undef_sechiba 
+    albedo(:,:)     = undef_sechiba
+    fluxsens(:)     = undef_sechiba
+    fluxlat(:)      = undef_sechiba
+    emis(:)         = undef_sechiba 
+    cdrag(:)        = undef_sechiba 
+    dswnet(:)       = undef_sechiba 
+    dswdown(:)      = undef_sechiba 
+    !
+    DO ik=1, kjpindex
+       
+       z0(kindex(ik))           = zz0(ik)
+       coastalflow(kindex(ik))  = zcoastal(ik)/1000.
+       riverflow(kindex(ik))    = zriver(ik)/1000.
+       tsol_rad(kindex(ik))     = ztsol_rad(ik)
+       vevapp(kindex(ik))       = zvevapp(ik)
+       temp_sol_new(kindex(ik)) = ztemp_sol_new(ik)
+       qsurf(kindex(ik))        = zqsurf(ik)
+       albedo(kindex(ik),1)     = zalbedo(ik,1)
+       albedo(kindex(ik),2)     = zalbedo(ik,2)
+       fluxsens(kindex(ik))     = zfluxsens(ik)
+       fluxlat(kindex(ik))      = zfluxlat(ik)
+       emis(kindex(ik))         = zemis(ik)
+       cdrag(kindex(ik))        = zcdrag(ik)
+       dswnet(kindex(ik))       = zswnet(ik)
+       dswdown(kindex(ik))      = zswdown(ik)
+
+    ENDDO
+    !
+    ! Modified fields for variables scattered during the writing
+    !
+    dcoastal(:) = (zcoastal(:))/1000.
+    driver(:)   = (zriver(:))/1000.
+    !
+    IF ( .NOT. l_first_intersurf) THEN
+       !
+       IF ( .NOT. almaoutput ) THEN
+          !
+          !  scattered during the writing
+          !
+          CALL histwrite (hist_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          !
+          CALL histwrite (hist_id, 'temp_sol', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'fluxlat',  itau_sechiba, fluxlat, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'swnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'swdown',   itau_sechiba, dswdown, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'alb_vis',  itau_sechiba, albedo(:,1), iim*jjm, kindex)
+          CALL histwrite (hist_id, 'alb_nir',  itau_sechiba, albedo(:,2), iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tair',     itau_sechiba, temp_air, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'qair',     itau_sechiba, qair, iim*jjm, kindex)
+          ! Ajouts Nathalie - Juin 2006 - sauvegarde de t2m et q2m
+          CALL histwrite (hist_id, 'q2m',     itau_sechiba, qair, iim*jjm, kindex)
+          CALL histwrite (hist_id, 't2m',     itau_sechiba, temp_air, iim*jjm, kindex)
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+             !
+             CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, fluxsens, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'fluxlat',  itau_sechiba, fluxlat, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'swnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'swdown',   itau_sechiba, dswdown, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'alb_vis',  itau_sechiba, albedo(:,1), iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'alb_nir',  itau_sechiba, albedo(:,2), iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tair',     itau_sechiba, temp_air, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'qair',     itau_sechiba, qair, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'q2m',     itau_sechiba, qair, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 't2m',     itau_sechiba, temp_air, iim*jjm, kindex)
+          ENDIF
+       ELSE
+          CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'Qle',  itau_sechiba, fluxlat, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'Qh', itau_sechiba, fluxsens, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'Qle',  itau_sechiba, fluxlat, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'RadT', itau_sechiba, temp_sol_NEW, iim*jjm, kindex)
+          ENDIF
+       ENDIF
+       !
+       IF (dw .EQ. xrdt) THEN
+          CALL histsync(hist_id)
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 6. Transform the water fluxes into Kg/m^2s and m^3/s
+    !
+    DO ik=1, kjpindex
+
+       vevapp(kindex(ik)) = vevapp(kindex(ik))/xrdt
+       coastalflow(kindex(ik)) = coastalflow(kindex(ik))/xrdt
+       riverflow(kindex(ik)) = riverflow(kindex(ik))/xrdt
+
+    ENDDO
+    !
+    IF ( lrestart_write .AND. ok_watchout ) THEN
+       CALL watchout_close()
+    ENDIF
+    !
+    IF(l_first_intersurf .AND. is_root_prc) CALL getin_dump
+    l_first_intersurf = .FALSE.
+    !
+    IF (long_print) WRITE (numout,*) ' intersurf_main done '
+    !
+    CALL ipslnlf(new_number=old_fileout)
+    !    
+  END SUBROUTINE intersurf_main_1d
+!
+!-------------------------------------------------------------------------------------
+!
+#ifdef CPP_PARA
+  SUBROUTINE intersurf_gathered (kjit, iim_glo, jjm_glo, offset, kjpindex, kindex, communicator, xrdt, &
+     & lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
+! First level conditions
+     & zlev,  u, v, qair, temp_air, epot_air, ccanopy, &
+! Variables for the implicit coupling
+     & cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+     & precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+     & vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
+! Surface temperatures and surface properties
+     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g) 
+#else
+  SUBROUTINE intersurf_gathered (kjit, iim_glo, jjm_glo, kjpindex, kindex, xrdt, &
+     & lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
+! First level conditions
+     & zlev,  u, v, qair, temp_air, epot_air, ccanopy, &
+! Variables for the implicit coupling
+     & cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+     & precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+     & vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
+! Surface temperatures and surface properties
+     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g) 
+#endif
+    ! routines called : sechiba_main
+    !
+    IMPLICIT NONE
+    !    
+    ! interface description for dummy arguments
+    ! input scalar 
+    INTEGER(i_std),INTENT (in)                            :: kjit          !! Time step number
+    INTEGER(i_std),INTENT (in)                            :: iim_glo, jjm_glo  !! Dimension of global fields
+#ifdef CPP_PARA
+    INTEGER(i_std),INTENT (in)                            :: offset        !! offset between the first global 2D point 
+                                                                           !! and the first local 2D point.
+    INTEGER(i_std),INTENT(IN)                             :: communicator  !! Orchidee communicator
+#endif
+    INTEGER(i_std),INTENT (in)                            :: kjpindex      !! Number of continental points
+    REAL(r_std),INTENT (in)                               :: xrdt          !! Time step in seconds
+    LOGICAL, INTENT (in)                                 :: lrestart_read !! Logical for _restart_ file to read
+    LOGICAL, INTENT (in)                                 :: lrestart_write!! Logical for _restart_ file to write'
+    REAL(r_std), INTENT (in)                              :: date0         !! Date at which kjit = 0
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)      :: kindex        !! Index for continental points
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: u             !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: v             !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: zlev          !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: qair          !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: precip_rain   !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: precip_snow   !! Snow precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: lwdown        !! Down-welling long-wave flux 
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: swnet         !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: swdown        !! Downwelling surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: temp_air      !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: epot_air      !! Air potential energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: ccanopy       !! CO2 concentration in the canopy
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: petAcoef      !! Coeficients A from the PBL resolution
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: peqAcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: petBcoef      !! Coeficients B from the PBL resolution
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: peqBcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (kjpindex), INTENT(inout)       :: cdrag         !! Cdrag
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: pb            !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(in)        :: latlon        !! Geographical coordinates
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: zcontfrac     !! Fraction of continent
+    INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in)    :: zneighbours   !! neighbours
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(in)        :: zresolution   !! size of the grid box
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: z0            !! Surface roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: coastalflow   !! Diffuse flow of water into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: riverflow     !! Largest rivers flowing into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: tsol_rad      !! Radiative surface temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: vevapp        !! Total of evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: temp_sol_new  !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: qsurf         !! Surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(out)       :: albedo        !! Albedo
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: fluxsens      !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: fluxlat       !! Latent chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: emis          !! Emissivity
+    ! LOCAL declaration
+    ! work arrays to scatter and/or gather information just before/after sechiba_main call's
+    ! and to keep output value for next call
+    REAL(r_std),DIMENSION (kjpindex)                      :: zccanopy      !! Work array to keep ccanopy
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_rain  !! Work array to keep precip_rain
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_snow  !! Work array to keep precip_snow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zz0           !! Work array to keep z0
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcdrag        !! Work array for surface drag
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcoastal      !! Work array to keep coastal flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zriver        !! Work array to keep river out flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: dcoastal      !! Work array to keep coastal flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: driver        !! Work array to keep river out flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztsol_rad     !! Work array to keep tsol_rad
+    REAL(r_std),DIMENSION (kjpindex)                      :: zvevapp       !! Work array to keep vevapp
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztemp_sol_new !! Work array to keep temp_sol_new
+    REAL(r_std),DIMENSION (kjpindex)                      :: zqsurf        !! Work array to keep qsurf
+    REAL(r_std),DIMENSION (kjpindex,2)                    :: zalbedo       !! Work array to keep albedo
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxsens     !! Work array to keep fluxsens
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxlat      !! Work array to keep fluxlat
+    REAL(r_std),DIMENSION (kjpindex)                      :: zemis         !! Work array to keep emis
+    !
+    ! Optional arguments
+    !
+    REAL(r_std),DIMENSION (iim_glo,jjm_glo), INTENT(IN), OPTIONAL :: lon_scat_g, lat_scat_g !! The scattered values for longitude 
+    !
+    INTEGER(i_std)                          :: iim,jjm                                  !! local sizes
+    REAL(r_std),DIMENSION (:,:),ALLOCATABLE :: lon_scat, lat_scat !! The scattered values for longitude 
+    !                                                                          !! and latitude.
+    !
+    ! Scattered variables for diagnostics
+    !
+!    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dvevapp       !! Diagnostic array for evaporation
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dtemp_sol     !! for surface temperature
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dfluxsens     !! for sensible heat flux
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dfluxlat      !! for latent heat flux
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dswnet        !! net solar radiation
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dswdown       !! Incident solar radiation
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:,:)                     :: dalbedo       !! albedo
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dtair         !! air temperature
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dqair         !! specific air humidity
+    !
+    !
+    INTEGER(i_std)                                        :: i, j, ik
+    INTEGER(i_std)                                        :: itau_sechiba
+    REAL(r_std)                                           :: mx, zlev_mean
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)              :: tmp_lon, tmp_lat, tmp_lev
+    LOGICAL                                               :: do_watch      !! if it's time, write watchout
+    INTEGER                                               :: old_fileout   !! old Logical Int for std IO output
+    LOGICAL :: check = .FALSE.
+    INTEGER(i_std),DIMENSION (kjpindex)                  :: kindex_p
+    !
+    LOGICAL, SAVE                                         :: fatmco2       !! Flag to force the value of atmospheric CO2 for vegetation.
+    REAL(r_std), SAVE                                     :: atmco2        !! atmospheric CO2 
+    !
+    CALL ipslnlf(old_number=old_fileout)
+    !
+    IF (l_first_intersurf) THEN
+       !
+       CALL intsurf_time( kjit, date0, xrdt )
+       !
+       IF ( check ) WRITE(numout,*) 'Initialisation of intersurf'
+       !
+       CALL ioget_calendar (one_year, one_day)
+       !
+#ifdef CPP_PARA
+       CALL init_para(.TRUE.,communicator)
+       kindex_p(:)=kindex(:) + offset
+#else
+       CALL init_para(.FALSE.)
+       kindex_p(:)=kindex(:)
+#endif
+       CALL ipslnlf(new_number=numout)
+       !
+       CALL init_data_para(iim_glo,jjm_glo,kjpindex,kindex_p)
+       iim=iim_glo
+       jjm=jj_nb
+       ALLOCATE(lon_scat(iim,jjm))
+       ALLOCATE(lat_scat(iim,jjm))
+!       ALLOCATE(dvevapp(iim*jjm))
+       ALLOCATE(dtemp_sol(iim*jjm))
+       ALLOCATE(dfluxsens(iim*jjm))
+       ALLOCATE(dfluxlat(iim*jjm))
+       ALLOCATE(dswnet(iim*jjm))
+       ALLOCATE(dswdown(iim*jjm))
+       ALLOCATE(dalbedo(iim*jjm,2))
+       ALLOCATE(dtair(iim*jjm))
+       ALLOCATE(dqair(iim*jjm))
+       
+!       CALL init_WriteField_p(kindex)
+       !
+       ! Allocation of grid variables
+       !
+       CALL init_grid ( kjpindex )
+       !
+       !  Create the internal coordinate table
+       !
+       lalo(:,:) = latlon(:,:)
+       CALL gather(lalo,lalo_g)
+       !
+       !-
+       !- Store variable to help describe the grid
+       !- once the points are gathered.
+       !-
+       neighbours(:,:) = zneighbours(:,:)
+       CALL gather(neighbours,neighbours_g)
+       !
+       resolution(:,:) = zresolution(:,:)
+       CALL gather(resolution,resolution_g)
+       !
+       area(:) = resolution(:,1)*resolution(:,2)
+       CALL gather(area,area_g)
+       !
+       !- Store the fraction of the continents only once so that the user
+       !- does not change them afterwards.
+       !
+       contfrac(:) = zcontfrac(:)
+       CALL gather(contfrac,contfrac_g)
+       !
+       !
+       !  Create the internal coordinate table
+       !
+       IF ( (.NOT.ALLOCATED(tmp_lon))) THEN
+          ALLOCATE(tmp_lon(iim,jjm))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lat))) THEN
+          ALLOCATE(tmp_lat(iim,jjm))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lev))) THEN
+          ALLOCATE(tmp_lev(iim,jjm))
+       ENDIF
+       !
+       !  Either we have the scattered coordinates as arguments or
+       !  we have to do the work here.
+       !
+       IF ( PRESENT(lon_scat_g) .AND. PRESENT(lat_scat_g)) THEN
+          
+          lon_scat(:,:)=zero
+          lat_scat(:,:)=zero 
+          CALL scatter2D(lon_scat_g,lon_scat)
+          CALL scatter2D(lat_scat_g,lat_scat)
+          lon_scat(:,1)=lon_scat(:,2)
+          lon_scat(:,jj_nb)=lon_scat(:,2)
+          lat_scat(:,1)=lat_scat(iim,1)
+          lat_scat(:,jj_nb)=lat_scat(1,jj_nb)
+          
+          tmp_lon(:,:) = lon_scat(:,:)
+          tmp_lat(:,:) = lat_scat(:,:)
+
+          IF (is_root_prc) THEN
+             lon_g(:,:) = lon_scat_g(:,:)
+             lat_g(:,:) = lat_scat_g(:,:)
+          ENDIF
+
+       ELSE IF ( PRESENT(lon_scat_g) .OR. PRESENT(lat_scat_g)) THEN
+
+          WRITE(numout,*) 'You need to provide the longitude AND latitude on the'
+          WRITE(numout,*) 'gathered grid in order to start ORCHIDEE.'
+          STOP 'intersurf_gathered'
+
+       ELSE
+          !
+          WRITE(numout,*) 'intersurf_gathered : We try to guess to full grid of the model.' 
+          WRITE(numout,*) 'I might fail, please report if it does. '
+          !
+          tmp_lon(:,:) = val_exp
+          tmp_lat(:,:) = val_exp
+          !
+          DO ik=1, kjpindex
+             j = INT( (kindex(ik)-1) / iim ) + 1
+             i = kindex(ik) - (j-1) * iim
+             tmp_lon(i,j) = lalo(ik,2)
+             tmp_lat(i,j) = lalo(ik,1)
+          ENDDO
+          !
+          ! Here we fill out the grid. To do this we do the strong hypothesis
+          ! that the grid is regular. Will this work in all cases ????
+          !
+          DO i=1,iim
+             mx = MAXVAL(tmp_lon(i,:), MASK=tmp_lon(i,:) .LT. val_exp)
+             IF ( mx .LT. val_exp ) THEN
+                tmp_lon(i,:) = mx
+             ELSE
+                WRITE(numout,*) 'Could not find a continental point on this longitude. Thus the grid'
+                WRITE(numout,*) 'could not be completed.'
+                STOP 'intersurf_gathered'
+             ENDIF
+          ENDDO
+          !
+          DO j=1,jjm
+             mx = MAXVAL(tmp_lat(:,j), MASK=tmp_lat(:,j) .LT. val_exp)
+             IF ( mx .LT. val_exp ) THEN
+                tmp_lat(:,j) = mx
+             ELSE
+                WRITE(numout,*) 'Could not find a continental point on this latitude. Thus the grid'
+                WRITE(numout,*) 'could not be completed.'
+                STOP 'intersurf_gathered'
+             ENDIF
+          ENDDO
+
+          CALL gather2D(tmp_lon,lon_g)
+          CALL gather2D(tmp_lat,lat_g)
+
+       ENDIF
+       !
+       DO ik=1, kjpindex
+          j = INT( (kindex(ik)-1) / iim ) + 1
+          i = kindex(ik) - (j-1) * iim
+          tmp_lev(i,j) = zlev(ik)
+       ENDDO
+       CALL gather2D(tmp_lev,zlev_g)
+       !
+       !
+       !  Configuration of SSL specific parameters
+       !
+       CALL intsurf_config(control_flags,xrdt)
+       !
+       !Config  Key  = FORCE_CO2_VEG
+       !Config  Desc = Flag to force the value of atmospheric CO2 for vegetation.
+       !Config  Def  = FALSE
+       !Config  Help = If this flag is set to true, the ATM_CO2 parameter is used
+       !Config         to prescribe the atmospheric CO2.
+       !Config         This Flag is only use in couple mode.
+       !
+       fatmco2=.FALSE.
+       CALL getin_p('FORCE_CO2_VEG',fatmco2)
+       !
+       ! Next flag is only use in couple mode with a gcm in intersurf.
+       ! In forced mode, it has already been read and set in driver.
+       IF ( fatmco2 ) THEN
+          !Config  Key  = ATM_CO2
+          !Config  IF   = FORCE_CO2_VEG (in not forced mode)
+          !Config  Desc = Value for atm CO2 
+          !Config  Def  = 350.
+          !Config  Help = Value to prescribe the atm CO2.
+          !Config         For pre-industrial simulations, the value is 286.2 .
+          !Config         348. for 1990 year.
+          !
+          atmco2=350.
+          CALL getin_p('ATM_CO2',atmco2)
+          WRITE(numout,*) 'atmco2 ',atmco2
+       ENDIF
+       
+       !
+       CALL intsurf_restart(kjit, iim, jjm, tmp_lon, tmp_lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
+       itau_sechiba = kjit + itau_offset
+       !
+       CALL intsurf_history(iim, jjm, tmp_lon, tmp_lat, itau_sechiba, &
+ &                          date0_shifted, xrdt, control_flags, hist_id, hist2_id, hist_id_stom, hist_id_stom_IPCC)
+       !
+       IF ( ok_watchout ) THEN
+          IF (is_root_prc) THEN
+             zlev_mean = zero
+             DO ik=1, nbp_glo
+                j = ((index_g(ik)-1)/iim_g) + 1
+                i = (index_g(ik) - (j-1)*iim_g)
+                
+                zlev_mean = zlev_mean + zlev_g(i,j)
+             ENDDO
+             zlev_mean = zlev_mean / REAL(nbp_glo,r_std)
+          ENDIF
+
+          last_action_watch = itau_sechiba
+          last_check_watch =  last_action_watch
+
+          CALL watchout_init(iim_g, jjm_g, kjpindex, nbp_glo, &
+               & date0_shifted, last_action_watch, dt_watch, index_g, lon_g, lat_g, zlev_mean)
+       ENDIF
+       !
+       IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
+       !
+    ENDIF
+    !
+    CALL ipslnlf(new_number=numout)
+    !
+    !  Shift the time step to phase the two models
+    !
+    itau_sechiba = kjit + itau_offset
+    !
+    CALL intsurf_time( itau_sechiba, date0_shifted, xrdt )
+    !
+    ! 1. Just change the units of some input fields
+    !
+    DO ik=1, kjpindex
+       
+       zprecip_rain(ik) = precip_rain(ik)*xrdt
+       zprecip_snow(ik) = precip_snow(ik)*xrdt
+       zcdrag(ik)       = cdrag(ik)
+       
+    ENDDO
+    !
+    IF (check_INPUTS) THEN
+       WRITE(numout,*) "Intersurf_main_gathered :"
+       WRITE(numout,*) "Time step number = ",kjit
+       WRITE(numout,*) "Dimension of input fields = ",iim, jjm
+       WRITE(numout,*) "Number of continental points = ",kjpindex
+       WRITE(numout,*) "Time step in seconds = ",xrdt
+       WRITE(numout,*) "Logical for _restart_ file to read, write = ",lrestart_read,lrestart_write
+       WRITE(numout,*) "Date at which kjit = 0  =  ",date0
+       WRITE(numout,*) "Index for continental points = ",kindex
+       WRITE(numout,*) "Lowest level wind speed North = ",u
+       WRITE(numout,*) "Lowest level wind speed East = ",v
+       WRITE(numout,*) "Height of first layer = ",zlev
+       WRITE(numout,*) "Lowest level specific humidity = ",qair
+       WRITE(numout,*) "Rain precipitation = ",zprecip_rain
+       WRITE(numout,*) "Snow precipitation = ",zprecip_snow
+       WRITE(numout,*) "Down-welling long-wave flux = ",lwdown
+       WRITE(numout,*) "Net surface short-wave flux = ",swnet
+       WRITE(numout,*) "Downwelling surface short-wave flux = ",swdown
+       WRITE(numout,*) "Air temperature in Kelvin = ",temp_air
+       WRITE(numout,*) "Air potential energy = ",epot_air
+       WRITE(numout,*) "CO2 concentration in the canopy = ",ccanopy
+       WRITE(numout,*) "Coeficients A from the PBL resolution = ",petAcoef
+       WRITE(numout,*) "One for T and another for q = ",peqAcoef
+       WRITE(numout,*) "Coeficients B from the PBL resolution = ",petBcoef
+       WRITE(numout,*) "One for T and another for q = ",peqBcoef
+       WRITE(numout,*) "Cdrag = ",zcdrag
+       WRITE(numout,*) "Lowest level pressure = ",pb
+       WRITE(numout,*) "Geographical coordinates lon = ", lon_scat
+       WRITE(numout,*) "Geographical coordinates lat = ", lat_scat 
+       WRITE(numout,*) "Fraction of continent in the grid = ",zcontfrac
+    ENDIF
+    !
+    ! 2. modification of co2
+    !
+    IF ( fatmco2 ) THEN
+       zccanopy(:) = atmco2
+       WRITE (numout,*) 'Modification of the ccanopy value. CO2 = ',atmco2
+    ELSE
+       zccanopy(:) = ccanopy(:)
+    ENDIF
+    !
+    ! 3. save the grid
+    !
+    IF ( check ) WRITE(numout,*) 'Save the grid'
+    !
+    IF (l_first_intersurf) THEN
+       CALL histwrite(hist_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+       CALL histwrite(hist_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       IF ( control_flags%ok_stomate ) THEN
+            CALL histwrite(hist_id_stom, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          IF ( hist_id_stom_IPCC > 0 ) THEN
+             CALL histwrite(hist_id_stom_IPCC, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          ENDIF
+       ENDIF
+       CALL histwrite(hist_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       CALL histsync(hist_id)
+       !
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+          CALL histsync(hist2_id)
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 4. call sechiba for continental points only
+    !
+    IF ( check ) WRITE(numout,*) 'Calling sechiba'
+    !
+    CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
+       & lrestart_read, lrestart_write, control_flags, &
+       & lalo, contfrac, neighbours, resolution, &
+! First level conditions
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
+!       & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
+       & zlev, u, v, qair, qair, temp_air, temp_air, epot_air, zccanopy, &
+! Variables for the implicit coupling
+       & zcdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+       & zprecip_rain ,zprecip_snow,  lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+       & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
+! Surface temperatures and surface properties
+       & ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
+! File ids
+       & rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC ) 
+    
+    !
+    IF ( check ) WRITE(numout,*) 'out of SECHIBA'
+    !
+    ! 5. save watchout 
+    !
+    IF ( ok_watchout .AND. .NOT. l_first_intersurf ) THEN
+       ! Accumulate last time step
+       sum_zlev(:) = sum_zlev(:) + zlev(:)
+       sum_u(:) = sum_u(:) + u(:)
+       sum_v(:) = sum_v(:) + v(:)
+       sum_qair(:) = sum_qair(:) + qair(:) 
+       sum_temp_air(:) = sum_temp_air(:) + temp_air(:)
+       sum_epot_air(:) = sum_epot_air(:) + epot_air(:)
+       sum_ccanopy(:) = sum_ccanopy(:) + ccanopy(:)
+       sum_cdrag(:) = sum_cdrag(:) + zcdrag(:)
+       sum_petAcoef(:) = sum_petAcoef(:) + petAcoef(:)
+       sum_peqAcoef(:) = sum_peqAcoef(:) + peqAcoef(:)
+       sum_petBcoef(:) = sum_petBcoef(:) + petBcoef(:)
+       sum_peqBcoef(:) = sum_peqBcoef(:) + peqBcoef(:)
+       sum_rain(:) = sum_rain(:) + zprecip_rain(:)
+       sum_snow(:) = sum_snow(:) + zprecip_snow(:)
+       sum_lwdown(:) = sum_lwdown(:) + lwdown(:)
+       sum_pb(:) = sum_pb(:) + pb(:)
+
+!!$       IF ( dt_watch > 3600 ) THEN 
+!!$          julian_watch = date0_shifted+((itau_sechiba-0.5)/dt_split_watch)*dt_watch/one_day
+!!$          CALL solarang (julian_watch, julian0, iim, jjm, tmp_lon, tmp_lat, sinang)
+!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) ) 
+!!$             isinang(:,:) = isinang(:,:) - 1
+!!$          ENDWHERE
+!!$          mean_sinang(:,:) = mean_sinang(:,:)+sinang(:,:)
+!!$          !
+!!$          DO ik=1,kjpindex          
+!!$             j = ((kindex(ik)-1)/iim) + 1
+!!$             i = (kindex(ik) - (j-1)*iim)
+!!$             
+!!$             sum_swnet(ik) = sum_swnet(ik) + sinang(i,j)*swnet(ik)
+!!$             sum_swdown(ik) = sum_swdown(ik) + sinang(i,j)*swdown(ik)
+!!$          ENDDO
+!!$       ELSE
+          sum_swnet(:) = sum_swnet(:) + swnet(:)
+          sum_swdown(:) = sum_swdown(:) + swdown(:)
+!!$       ENDIF
+       
+       do_watch = .FALSE.
+       call isittime &
+            &  (itau_sechiba,date0_shifted,xrdt,dt_watch,&
+            &   last_action_watch,last_check_watch,do_watch)
+       last_check_watch = itau_sechiba
+       IF (do_watch) THEN
+          !
+          IF ( check ) WRITE(numout,*) 'save watchout'
+          !
+          IF (long_print) THEN
+             WRITE(numout,*) "intersurf : write watchout for date ",date0,date0_shifted,itau_sechiba, & 
+                  & last_action_watch,last_check_watch
+          ENDIF
+          last_action_watch = itau_sechiba
+
+          sum_zlev(:) = sum_zlev(:) / dt_split_watch
+          sum_u(:) = sum_u(:) / dt_split_watch
+          sum_v(:) = sum_v(:) / dt_split_watch
+          sum_qair(:) = sum_qair(:) / dt_split_watch
+          sum_temp_air(:) = sum_temp_air(:) / dt_split_watch
+          sum_epot_air(:) = sum_epot_air(:) / dt_split_watch
+          sum_ccanopy(:) = sum_ccanopy(:) / dt_split_watch
+          sum_cdrag(:) = sum_cdrag(:) / dt_split_watch
+          sum_petAcoef(:) = sum_petAcoef(:) / dt_split_watch
+          sum_peqAcoef(:) = sum_peqAcoef(:) / dt_split_watch
+          sum_petBcoef(:) = sum_petBcoef(:) / dt_split_watch
+          sum_peqBcoef(:) = sum_peqBcoef(:) / dt_split_watch
+          sum_rain(:) = sum_rain(:) / dt_split_watch
+          sum_snow(:) = sum_snow(:) / dt_split_watch
+          sum_lwdown(:) = sum_lwdown(:) / dt_split_watch
+          sum_pb(:) = sum_pb(:) / dt_split_watch
+
+!!$          IF ( dt_watch > 3600 ) THEN 
+!!$             WHERE ( isinang(:,:) .GT. 0 )
+!!$                mean_sinang(:,:) = mean_sinang(:,:) / isinang(:,:)
+!!$             ENDWHERE
+!!$             !
+!!$             DO ik=1,kjpindex          
+!!$                j = ((kindex(ik)-1)/iim) + 1
+!!$                i = (kindex(ik) - (j-1)*iim)
+!!$                IF (mean_sinang(i,j) > zero) THEN
+!!$                   sum_swdown(ik) = sum_swdown(ik)/mean_sinang(i,j)
+!!$                   sum_swnet(ik) =  sum_swnet(ik)/mean_sinang(i,j)
+!!$                ELSE
+!!$                   sum_swdown(ik) = zero
+!!$                   sum_swnet(ik) =  zero
+!!$                ENDIF
+!!$             ENDDO
+!!$          ELSE
+             sum_swnet(:) = sum_swnet(:) / dt_split_watch
+             sum_swdown(:) = sum_swdown(:) / dt_split_watch
+!!$          ENDIF
+
+          CALL watchout_write_p(kjpindex, itau_sechiba, xrdt, sum_zlev, sum_swdown, sum_rain, &
+               &   sum_snow, sum_lwdown, sum_pb, sum_temp_air, sum_epot_air, sum_qair, &
+               &   sum_u, sum_v, sum_swnet, sum_petAcoef, sum_peqAcoef, sum_petBcoef, sum_peqBcoef, &
+               &   sum_cdrag, sum_ccanopy )
+       ENDIF       
+    ENDIF
+    !
+    ! 6. scatter output fields
+    !
+    z0(:)           = undef_sechiba
+    coastalflow(:)  = undef_sechiba
+    riverflow(:)    = undef_sechiba
+    tsol_rad(:)     = undef_sechiba
+    vevapp(:)       = undef_sechiba
+    temp_sol_new(:) = undef_sechiba
+    qsurf(:)        = undef_sechiba
+    albedo(:,1)     = undef_sechiba
+    albedo(:,2)     = undef_sechiba
+    fluxsens(:)     = undef_sechiba
+    fluxlat(:)      = undef_sechiba
+    emis(:)         = undef_sechiba
+    cdrag(:)        = undef_sechiba
+    !    
+!    dvevapp(:)    = undef_sechiba
+    dtemp_sol(:)  = undef_sechiba
+    dfluxsens(:)  = undef_sechiba
+    dfluxlat(:)   = undef_sechiba
+    dswnet (:)    = undef_sechiba
+    dswdown (:)   = undef_sechiba
+    dalbedo (:,1) = undef_sechiba
+    dalbedo (:,2) = undef_sechiba
+    dtair (:)     = undef_sechiba
+    dqair (:)     = undef_sechiba
+    !
+    DO ik=1, kjpindex
+       
+       z0(ik)           = zz0(ik)
+       coastalflow(ik)  = zcoastal(ik)/1000.
+       riverflow(ik)    = zriver(ik)/1000.
+       tsol_rad(ik)     = ztsol_rad(ik)
+       vevapp(ik)       = zvevapp(ik)
+       temp_sol_new(ik) = ztemp_sol_new(ik)
+       qsurf(ik)        = zqsurf(ik)
+       albedo(ik,1)     = zalbedo(ik,1)
+       albedo(ik,2)     = zalbedo(ik,2)
+       fluxsens(ik)     = zfluxsens(ik)
+       fluxlat(ik)      = zfluxlat(ik)
+       emis(ik)         = zemis(ik)
+       cdrag(ik)        = zcdrag(ik)
+       
+       ! Fill up the diagnostic arrays
+
+!       dvevapp(kindex(ik))    = zvevapp(ik)
+       dtemp_sol(kindex(ik))  = ztemp_sol_new(ik)
+       dfluxsens(kindex(ik))  = zfluxsens(ik)
+       dfluxlat(kindex(ik))   = zfluxlat(ik)
+       dswnet (kindex(ik))    = swnet(ik)
+       dswdown (kindex(ik))   = swdown(ik)
+       dalbedo (kindex(ik),1) = zalbedo(ik,1)
+       dalbedo (kindex(ik),2) = zalbedo(ik,2)   
+       dtair (kindex(ik))     = temp_air(ik)
+       dqair (kindex(ik))     = qair(ik)
+       !
+    ENDDO
+    !
+    ! Modified fields for variables scattered during the writing
+    !
+    dcoastal(:) = (zcoastal(:))/1000.
+    driver(:)   = (zriver(:))/1000.
+    !
+    IF ( .NOT. l_first_intersurf) THEN
+       !
+       IF ( .NOT. almaoutput ) THEN
+          !
+          !  scattered during the writing
+          !           
+          CALL histwrite (hist_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          ! 
+          CALL histwrite (hist_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'fluxlat',  itau_sechiba, dfluxlat,  iim*jjm, kindex)
+          CALL histwrite (hist_id, 'swnet',    itau_sechiba, dswnet,    iim*jjm, kindex)
+          CALL histwrite (hist_id, 'swdown',   itau_sechiba, dswdown,   iim*jjm, kindex)
+          CALL histwrite (hist_id, 'alb_vis',  itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
+          CALL histwrite (hist_id, 'alb_nir',  itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tair',     itau_sechiba, dtair, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'qair',     itau_sechiba, dqair, iim*jjm, kindex)
+          CALL histwrite (hist_id, 't2m',      itau_sechiba, dtair, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'q2m',      itau_sechiba, dqair, iim*jjm, kindex)
+          !
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+             ! 
+             CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'fluxlat',  itau_sechiba, dfluxlat,  iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'swnet',    itau_sechiba, dswnet,    iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'swdown',   itau_sechiba, dswdown,   iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'alb_vis',  itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'alb_nir',  itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tair',     itau_sechiba, dtair, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'qair',     itau_sechiba, dqair, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 't2m',      itau_sechiba, dtair, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'q2m',      itau_sechiba, dqair, iim*jjm, kindex)
+          ENDIF
+       ELSE
+          CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'Qle',  itau_sechiba, dfluxlat, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          !
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'Qle',  itau_sechiba, dfluxlat, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          ENDIF
+       ENDIF
+       !
+       IF (dw .EQ. xrdt) THEN
+          CALL histsync(hist_id)
+       ENDIF
+    !
+    ENDIF
+    !
+    ! 7. Transform the water fluxes into Kg/m^2s and m^3/s
+    !
+    DO ik=1, kjpindex
+
+       vevapp(ik) = vevapp(ik)/xrdt
+       coastalflow(ik) = coastalflow(ik)/xrdt
+       riverflow(ik) = riverflow(ik)/xrdt
+
+    ENDDO
+    !
+    IF ( lrestart_write .AND. ok_watchout .AND. is_root_prc ) THEN
+       CALL watchout_close()
+    ENDIF
+    !
+    IF(l_first_intersurf .AND. is_root_prc) CALL getin_dump
+    l_first_intersurf = .FALSE.
+    !
+    IF (long_print) WRITE (numout,*) ' intersurf_main done '
+    !
+    CALL ipslnlf(new_number=old_fileout)
+    !        
+  END SUBROUTINE intersurf_gathered
+!
+!
+#ifdef CPP_PARA
+  SUBROUTINE intersurf_gathered_2m (kjit, iim_glo, jjm_glo, offset, kjpindex, kindex, communicator, xrdt, &
+     & lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
+! First level conditions
+     & zlev,  u, v, qair, temp_air, epot_air, ccanopy, &
+! Variables for the implicit coupling
+     & cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+     & precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+     & vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
+! Surface temperatures and surface properties
+!     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g) 
+     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g, &
+! Ajout Nathalie - passage q2m/t2m pour calcul Rveget
+     & q2m, t2m)  
+#else
+  SUBROUTINE intersurf_gathered_2m (kjit, iim_glo, jjm_glo, kjpindex, kindex, xrdt, &
+     & lrestart_read, lrestart_write, latlon, zcontfrac, zneighbours, zresolution, date0, &
+! First level conditions
+     & zlev,  u, v, qair, temp_air, epot_air, ccanopy, &
+! Variables for the implicit coupling
+     & cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+     & precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+     & vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
+! Surface temperatures and surface properties
+!     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g)
+     & tsol_rad, temp_sol_new, qsurf, albedo, emis, z0, lon_scat_g, lat_scat_g, &
+! Ajout Nathalie - passage q2m/t2m pour calcul Rveget
+     & q2m, t2m)  
+#endif
+    ! routines called : sechiba_main
+    !
+    IMPLICIT NONE
+    !    
+    ! interface description for dummy arguments
+    ! input scalar 
+    INTEGER(i_std),INTENT (in)                            :: kjit          !! Time step number
+    INTEGER(i_std),INTENT (in)                            :: iim_glo, jjm_glo  !! Dimension of global fields
+#ifdef CPP_PARA
+    INTEGER(i_std),INTENT (in)                            :: offset        !! offset between the first global 2D point 
+                                                                           !! and the first local 2D point.
+    INTEGER(i_std),INTENT(IN)                             :: communicator  !! Orchidee communicator
+#endif
+    INTEGER(i_std),INTENT (in)                            :: kjpindex      !! Number of continental points
+    REAL(r_std),INTENT (in)                               :: xrdt          !! Time step in seconds
+    LOGICAL, INTENT (in)                                 :: lrestart_read !! Logical for _restart_ file to read
+    LOGICAL, INTENT (in)                                 :: lrestart_write!! Logical for _restart_ file to write'
+    REAL(r_std), INTENT (in)                              :: date0         !! Date at which kjit = 0
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)      :: kindex        !! Index for continental points
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: u             !! Lowest level wind speed
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: v             !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: zlev          !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: qair          !! Lowest level specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: precip_rain   !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: precip_snow   !! Snow precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: lwdown        !! Down-welling long-wave flux 
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: swnet         !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: swdown        !! Downwelling surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: temp_air      !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: epot_air      !! Air potential energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: ccanopy       !! CO2 concentration in the canopy
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: petAcoef      !! Coeficients A from the PBL resolution
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: peqAcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: petBcoef      !! Coeficients B from the PBL resolution
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: peqBcoef      !! One for T and another for q
+    REAL(r_std),DIMENSION (kjpindex), INTENT(inout)       :: cdrag         !! Cdrag
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: pb            !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(in)        :: latlon        !! Geographical coordinates
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: zcontfrac     !! Fraction of continent
+    INTEGER(i_std),DIMENSION (kjpindex,8), INTENT(in)    :: zneighbours   !! neighbours
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(in)        :: zresolution   !! size of the grid box
+! Ajout Nathalie - Juin 2006 - q2m/t2m pour calcul Rveget
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: q2m          !! Surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT(in)          :: t2m          !! Surface air temperature
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: z0            !! Surface roughness
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: coastalflow   !! Diffuse flow of water into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: riverflow     !! Largest rivers flowing into the ocean (m^3/dt)
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: tsol_rad      !! Radiative surface temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: vevapp        !! Total of evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: temp_sol_new  !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: qsurf         !! Surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT(out)       :: albedo        !! Albedo
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: fluxsens      !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: fluxlat       !! Latent chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT(out)         :: emis          !! Emissivity
+    ! LOCAL declaration
+    ! work arrays to scatter and/or gather information just before/after sechiba_main call's
+    ! and to keep output value for next call
+    REAL(r_std),DIMENSION (kjpindex)                      :: zccanopy      !! Work array to keep ccanopy
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_rain  !! Work array to keep precip_rain
+    REAL(r_std),DIMENSION (kjpindex)                      :: zprecip_snow  !! Work array to keep precip_snow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zz0           !! Work array to keep z0
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcdrag        !! Work array for surface drag
+    REAL(r_std),DIMENSION (kjpindex)                      :: zcoastal      !! Work array to keep coastal flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: zriver        !! Work array to keep river out flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: dcoastal      !! Work array to keep coastal flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: driver        !! Work array to keep river out flow
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztsol_rad     !! Work array to keep tsol_rad
+    REAL(r_std),DIMENSION (kjpindex)                      :: zvevapp       !! Work array to keep vevapp
+    REAL(r_std),DIMENSION (kjpindex)                      :: ztemp_sol_new !! Work array to keep temp_sol_new
+    REAL(r_std),DIMENSION (kjpindex)                      :: zqsurf        !! Work array to keep qsurf
+    REAL(r_std),DIMENSION (kjpindex,2)                    :: zalbedo       !! Work array to keep albedo
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxsens     !! Work array to keep fluxsens
+    REAL(r_std),DIMENSION (kjpindex)                      :: zfluxlat      !! Work array to keep fluxlat
+    REAL(r_std),DIMENSION (kjpindex)                      :: zemis         !! Work array to keep emis
+    !
+    ! Optional arguments
+    !
+    REAL(r_std),DIMENSION (iim_glo,jjm_glo), INTENT(IN), OPTIONAL :: lon_scat_g, lat_scat_g !! The scattered values for longitude 
+    !
+    INTEGER(i_std)                          :: iim,jjm                                  !! local sizes
+    REAL(r_std),DIMENSION (:,:),ALLOCATABLE :: lon_scat, lat_scat !! The scattered values for longitude 
+    !                                                                          !! and latitude.
+    !
+    ! Scattered variables for diagnostics
+    !
+!    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dvevapp       !! Diagnostic array for evaporation
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dtemp_sol     !! for surface temperature
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dfluxsens     !! for sensible heat flux
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dfluxlat      !! for latent heat flux
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dswnet        !! net solar radiation
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dswdown       !! Incident solar radiation
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:,:)                     :: dalbedo       !! albedo
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dtair         !! air temperature
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dqair         !! specific air humidity
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dq2m          !! Surface specific humidity
+    REAL(r_std),ALLOCATABLE,SAVE,DIMENSION (:)                       :: dt2m          !! Surface air temperature
+    !
+    !
+    INTEGER(i_std)                                        :: i, j, ik
+    INTEGER(i_std)                                        :: itau_sechiba
+    REAL(r_std)                                           :: mx, zlev_mean
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)              :: tmp_lon, tmp_lat, tmp_lev
+    LOGICAL                                               :: do_watch      !! if it's time, write watchout
+    INTEGER                                               :: old_fileout   !! old Logical Int for std IO output
+    LOGICAL :: check = .FALSE.
+    INTEGER(i_std),DIMENSION (kjpindex)                  :: kindex_p
+    !
+    LOGICAL, SAVE                                         :: fatmco2       !! Flag to force the value of atmospheric CO2 for vegetation.
+    REAL(r_std), SAVE                                     :: atmco2        !! atmospheric CO2 
+    !
+    CALL ipslnlf(old_number=old_fileout)
+    !
+    IF (l_first_intersurf) THEN
+       !
+       CALL intsurf_time( kjit, date0, xrdt )
+       !
+       IF ( check ) WRITE(numout,*) 'Initialisation of intersurf'
+       !
+       CALL ioget_calendar (one_year, one_day)
+       !
+#ifdef CPP_PARA
+       CALL init_para(.TRUE.,communicator)
+       kindex_p(:)=kindex(:) + offset
+#else
+       CALL init_para(.FALSE.)
+       kindex_p(:)=kindex(:)
+#endif
+       CALL ipslnlf(new_number=numout)
+       !
+       CALL init_data_para(iim_glo,jjm_glo,kjpindex,kindex_p)
+       iim=iim_glo
+       jjm=jj_nb
+       ALLOCATE(lon_scat(iim,jjm))
+       ALLOCATE(lat_scat(iim,jjm))
+!       ALLOCATE(dvevapp(iim*jjm))
+       ALLOCATE(dtemp_sol(iim*jjm))
+       ALLOCATE(dfluxsens(iim*jjm))
+       ALLOCATE(dfluxlat(iim*jjm))
+       ALLOCATE(dswnet(iim*jjm))
+       ALLOCATE(dswdown(iim*jjm))
+       ALLOCATE(dalbedo(iim*jjm,2))
+       ALLOCATE(dtair(iim*jjm))
+       ALLOCATE(dqair(iim*jjm)) 
+       ALLOCATE(dq2m(iim*jjm))
+       ALLOCATE(dt2m(iim*jjm))
+      
+!       CALL init_WriteField_p(kindex)
+       !
+       ! Allocation of grid variables
+       !
+       CALL init_grid ( kjpindex )
+       !
+       !  Create the internal coordinate table
+       !
+       lalo(:,:) = latlon(:,:)
+       CALL gather(lalo,lalo_g)
+       !
+       !-
+       !- Store variable to help describe the grid
+       !- once the points are gathered.
+       !-
+       neighbours(:,:) = zneighbours(:,:)
+       CALL gather(neighbours,neighbours_g)
+       !
+       resolution(:,:) = zresolution(:,:)
+       CALL gather(resolution,resolution_g)
+       !
+       area(:) = resolution(:,1)*resolution(:,2)
+       CALL gather(area,area_g)
+       !
+       !- Store the fraction of the continents only once so that the user
+       !- does not change them afterwards.
+       !
+       contfrac(:) = zcontfrac(:)
+       CALL gather(contfrac,contfrac_g)
+       !
+       !
+       !  Create the internal coordinate table
+       !
+       IF ( (.NOT.ALLOCATED(tmp_lon))) THEN
+          ALLOCATE(tmp_lon(iim,jjm))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lat))) THEN
+          ALLOCATE(tmp_lat(iim,jjm))
+       ENDIF
+       IF ( (.NOT.ALLOCATED(tmp_lev))) THEN
+          ALLOCATE(tmp_lev(iim,jjm))
+       ENDIF
+       !
+       !  Either we have the scattered coordinates as arguments or
+       !  we have to do the work here.
+       !
+       IF ( PRESENT(lon_scat_g) .AND. PRESENT(lat_scat_g)) THEN
+          
+          lon_scat(:,:)=zero
+          lat_scat(:,:)=zero 
+          CALL scatter2D(lon_scat_g,lon_scat)
+          CALL scatter2D(lat_scat_g,lat_scat)
+          lon_scat(:,1)=lon_scat(:,2)
+          lon_scat(:,jj_nb)=lon_scat(:,2)
+          lat_scat(:,1)=lat_scat(iim,1)
+          lat_scat(:,jj_nb)=lat_scat(1,jj_nb)
+          
+          tmp_lon(:,:) = lon_scat(:,:)
+          tmp_lat(:,:) = lat_scat(:,:)
+
+          IF (is_root_prc) THEN
+             lon_g(:,:) = lon_scat_g(:,:)
+             lat_g(:,:) = lat_scat_g(:,:)
+          ENDIF
+
+       ELSE IF ( PRESENT(lon_scat_g) .OR. PRESENT(lat_scat_g)) THEN
+
+          WRITE(numout,*) 'You need to provide the longitude AND latitude on the'
+          WRITE(numout,*) 'gathered grid in order to start ORCHIDEE.'
+          STOP 'intersurf_gathered'
+
+       ELSE
+          !
+          WRITE(numout,*) 'intersurf_gathered : We try to guess to full grid of the model.' 
+          WRITE(numout,*) 'I might fail, please report if it does. '
+          !
+          tmp_lon(:,:) = val_exp
+          tmp_lat(:,:) = val_exp
+          !
+          DO ik=1, kjpindex
+             j = INT( (kindex(ik)-1) / iim ) + 1
+             i = kindex(ik) - (j-1) * iim
+             tmp_lon(i,j) = lalo(ik,2)
+             tmp_lat(i,j) = lalo(ik,1)
+          ENDDO
+          !
+          ! Here we fill out the grid. To do this we do the strong hypothesis
+          ! that the grid is regular. Will this work in all cases ????
+          !
+          DO i=1,iim
+             mx = MAXVAL(tmp_lon(i,:), MASK=tmp_lon(i,:) .LT. val_exp)
+             IF ( mx .LT. val_exp ) THEN
+                tmp_lon(i,:) = mx
+             ELSE
+                WRITE(numout,*) 'Could not find a continental point on this longitude. Thus the grid'
+                WRITE(numout,*) 'could not be completed.'
+                STOP 'intersurf_gathered'
+             ENDIF
+          ENDDO
+          !
+          DO j=1,jjm
+             mx = MAXVAL(tmp_lat(:,j), MASK=tmp_lat(:,j) .LT. val_exp)
+             IF ( mx .LT. val_exp ) THEN
+                tmp_lat(:,j) = mx
+             ELSE
+                WRITE(numout,*) 'Could not find a continental point on this latitude. Thus the grid'
+                WRITE(numout,*) 'could not be completed.'
+                STOP 'intersurf_gathered'
+             ENDIF
+          ENDDO
+
+          CALL gather2D(tmp_lon,lon_g)
+          CALL gather2D(tmp_lat,lat_g)
+
+       ENDIF
+       !
+       DO ik=1, kjpindex
+          j = INT( (kindex(ik)-1) / iim ) + 1
+          i = kindex(ik) - (j-1) * iim
+          tmp_lev(i,j) = zlev(ik)
+       ENDDO
+       CALL gather2D(tmp_lev,zlev_g)
+       !
+       !
+       !  Configuration of SSL specific parameters
+       !
+       CALL intsurf_config(control_flags,xrdt)
+       !
+       !Config  Key  = FORCE_CO2_VEG
+       !Config  Desc = Flag to force the value of atmospheric CO2 for vegetation.
+       !Config  Def  = FALSE
+       !Config  Help = If this flag is set to true, the ATM_CO2 parameter is used
+       !Config         to prescribe the atmospheric CO2.
+       !Config         This Flag is only use in couple mode.
+       !
+       fatmco2=.FALSE.
+       CALL getin_p('FORCE_CO2_VEG',fatmco2)
+       !
+       ! Next flag is only use in couple mode with a gcm in intersurf.
+       ! In forced mode, it has already been read and set in driver.
+       IF ( fatmco2 ) THEN
+          !Config  Key  = ATM_CO2
+          !Config  IF   = FORCE_CO2_VEG (in not forced mode)
+          !Config  Desc = Value for atm CO2 
+          !Config  Def  = 350.
+          !Config  Help = Value to prescribe the atm CO2.
+          !Config         For pre-industrial simulations, the value is 286.2 .
+          !Config         348. for 1990 year.
+          !
+          atmco2=350.
+          CALL getin_p('ATM_CO2',atmco2)
+          WRITE(numout,*) 'atmco2 ',atmco2
+       ENDIF
+       
+       !
+       CALL intsurf_restart(kjit, iim, jjm, tmp_lon, tmp_lat, date0, xrdt, control_flags, rest_id, rest_id_stom, itau_offset)
+       itau_sechiba = kjit + itau_offset
+       !
+       CALL intsurf_history(iim, jjm, tmp_lon, tmp_lat, itau_sechiba, &
+ &                          date0_shifted, xrdt, control_flags, hist_id, hist2_id, hist_id_stom, hist_id_stom_IPCC)
+       !
+       IF ( ok_watchout ) THEN
+          IF (is_root_prc) THEN
+             zlev_mean = zero
+             DO ik=1, nbp_glo
+                j = ((index_g(ik)-1)/iim_g) + 1
+                i = (index_g(ik) - (j-1)*iim_g)
+                
+                zlev_mean = zlev_mean + zlev_g(i,j)
+             ENDDO
+             zlev_mean = zlev_mean / REAL(nbp_glo,r_std)
+          ENDIF
+
+          last_action_watch = itau_sechiba
+          last_check_watch =  last_action_watch
+
+          ! Only root proc write watchout file
+          CALL watchout_init(iim_g, jjm_g, kjpindex, nbp_glo, &
+               & date0_shifted, last_action_watch, dt_watch, index_g, lon_g, lat_g, zlev_mean)
+       ENDIF
+       !
+       IF ( check ) WRITE(numout,*) 'End of Initialisation of intersurf'
+       !
+    ENDIF
+    !
+    CALL ipslnlf(new_number=numout)
+    !
+    !  Shift the time step to phase the two models
+    !
+    itau_sechiba = kjit + itau_offset
+    !
+    CALL intsurf_time( itau_sechiba, date0_shifted, xrdt )
+    !
+    ! 1. Just change the units of some input fields
+    !
+    DO ik=1, kjpindex
+       
+       zprecip_rain(ik) = precip_rain(ik)*xrdt
+       zprecip_snow(ik) = precip_snow(ik)*xrdt
+       zcdrag(ik)       = cdrag(ik)
+       
+    ENDDO
+    !
+    IF (check_INPUTS) THEN
+       WRITE(numout,*) "Intersurf_main_gathered :"
+       WRITE(numout,*) "Time step number = ",kjit
+       WRITE(numout,*) "Dimension of input fields = ",iim, jjm
+       WRITE(numout,*) "Number of continental points = ",kjpindex
+       WRITE(numout,*) "Time step in seconds = ",xrdt
+       WRITE(numout,*) "Logical for _restart_ file to read, write = ",lrestart_read,lrestart_write
+       WRITE(numout,*) "Date at which kjit = 0  =  ",date0
+       WRITE(numout,*) "Index for continental points = ",kindex
+       WRITE(numout,*) "Lowest level wind speed North = ",u
+       WRITE(numout,*) "Lowest level wind speed East = ",v
+       WRITE(numout,*) "Height of first layer = ",zlev
+       WRITE(numout,*) "Lowest level specific humidity = ",qair
+       WRITE(numout,*) "Rain precipitation = ",zprecip_rain
+       WRITE(numout,*) "Snow precipitation = ",zprecip_snow
+       WRITE(numout,*) "Down-welling long-wave flux = ",lwdown
+       WRITE(numout,*) "Net surface short-wave flux = ",swnet
+       WRITE(numout,*) "Downwelling surface short-wave flux = ",swdown
+       WRITE(numout,*) "Air temperature in Kelvin = ",temp_air
+       WRITE(numout,*) "Air potential energy = ",epot_air
+       WRITE(numout,*) "CO2 concentration in the canopy = ",ccanopy
+       WRITE(numout,*) "Coeficients A from the PBL resolution = ",petAcoef
+       WRITE(numout,*) "One for T and another for q = ",peqAcoef
+       WRITE(numout,*) "Coeficients B from the PBL resolution = ",petBcoef
+       WRITE(numout,*) "One for T and another for q = ",peqBcoef
+       WRITE(numout,*) "Cdrag = ",zcdrag
+       WRITE(numout,*) "Lowest level pressure = ",pb
+       WRITE(numout,*) "Geographical coordinates lon = ", lon_scat
+       WRITE(numout,*) "Geographical coordinates lat = ", lat_scat 
+       WRITE(numout,*) "Fraction of continent in the grid = ",zcontfrac
+    ENDIF
+    !
+    ! 2. modification of co2
+    !
+    IF ( fatmco2 ) THEN
+       zccanopy(:) = atmco2
+       WRITE (numout,*) 'Modification of the ccanopy value. CO2 = ',atmco2
+    ELSE
+       zccanopy(:) = ccanopy(:)
+    ENDIF
+    !
+    ! 3. save the grid
+    !
+    IF ( check ) WRITE(numout,*) 'Save the grid'
+    !
+    IF (l_first_intersurf) THEN
+       CALL histwrite(hist_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+       CALL histwrite(hist_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histwrite(hist_id_stom, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          IF ( hist_id_stom_ipcc > 0 ) &
+               CALL histwrite(hist_id_stom_IPCC, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+       ENDIF
+       CALL histwrite(hist_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+       CALL histsync(hist_id)
+       !
+       IF ( hist2_id > 0 ) THEN
+          CALL histwrite(hist2_id, 'LandPoints',  itau_sechiba+1, (/ ( REAL(ik), ik=1,kjpindex ) /), kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Areas',  itau_sechiba+1, area, kjpindex, kindex)
+          CALL histwrite(hist2_id, 'Contfrac',  itau_sechiba+1, contfrac, kjpindex, kindex)
+          CALL histsync(hist2_id)
+       ENDIF
+       !
+    ENDIF
+    !
+    ! 4. call sechiba for continental points only
+    !
+    IF ( check ) WRITE(numout,*) 'Calling sechiba'
+    !
+    CALL sechiba_main (itau_sechiba, iim*jjm, kjpindex, kindex, xrdt, date0_shifted, &
+       & lrestart_read, lrestart_write, control_flags, &
+       & lalo, contfrac, neighbours, resolution, &
+! First level conditions
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul rveget
+!       & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
+       & zlev, u, v, qair, q2m, t2m, temp_air, epot_air, zccanopy, &
+! Variables for the implicit coupling
+       & zcdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+! Rain, snow, radiation and surface pressure
+       & zprecip_rain ,zprecip_snow,  lwdown, swnet, swdown, pb, &
+! Output : Fluxes
+       & zvevapp, zfluxsens, zfluxlat, zcoastal, zriver, &
+! Surface temperatures and surface properties
+       & ztsol_rad, ztemp_sol_new, zqsurf, zalbedo, zemis, zz0, &
+! File ids
+       & rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC ) 
+    
+    !
+    IF ( check ) WRITE(numout,*) 'out of SECHIBA'
+    !
+    ! 5. save watchout 
+    !
+    IF ( ok_watchout .AND. .NOT. l_first_intersurf ) THEN
+       ! Accumulate last time step
+       sum_zlev(:) = sum_zlev(:) + zlev(:)
+       sum_u(:) = sum_u(:) + u(:)
+       sum_v(:) = sum_v(:) + v(:)
+       sum_qair(:) = sum_qair(:) + qair(:) 
+       sum_temp_air(:) = sum_temp_air(:) + temp_air(:)
+       sum_epot_air(:) = sum_epot_air(:) + epot_air(:)
+       sum_ccanopy(:) = sum_ccanopy(:) + ccanopy(:)
+       sum_cdrag(:) = sum_cdrag(:) + zcdrag(:)
+       sum_petAcoef(:) = sum_petAcoef(:) + petAcoef(:)
+       sum_peqAcoef(:) = sum_peqAcoef(:) + peqAcoef(:)
+       sum_petBcoef(:) = sum_petBcoef(:) + petBcoef(:)
+       sum_peqBcoef(:) = sum_peqBcoef(:) + peqBcoef(:)
+       sum_rain(:) = sum_rain(:) + zprecip_rain(:)
+       sum_snow(:) = sum_snow(:) + zprecip_snow(:)
+       sum_lwdown(:) = sum_lwdown(:) + lwdown(:)
+       sum_pb(:) = sum_pb(:) + pb(:)
+
+!!$       IF ( dt_watch > 3600 ) THEN 
+!!$          julian_watch = date0_shifted+((itau_sechiba-0.5)/dt_split_watch)*dt_watch/one_day
+!!$          CALL solarang (julian_watch, julian0, iim, jjm, tmp_lon, tmp_lat, sinang)
+!!$          WHERE ( sinang(:,:) .LT. EPSILON(un) )
+!!$             isinang(:,:) = isinang(:,:) - 1
+!!$          ENDWHERE
+!!$          mean_sinang(:,:) = mean_sinang(:,:)+sinang(:,:)
+!!$          !
+!!$          DO ik=1,kjpindex          
+!!$             j = ((kindex(ik)-1)/iim) + 1
+!!$             i = (kindex(ik) - (j-1)*iim)
+!!$             
+!!$             sum_swnet(ik) = sum_swnet(ik) + sinang(i,j)*swnet(ik)
+!!$             sum_swdown(ik) = sum_swdown(ik) + sinang(i,j)*swdown(ik)
+!!$          ENDDO
+!!$       ELSE
+          sum_swnet(:) = sum_swnet(:) + swnet(:)
+          sum_swdown(:) = sum_swdown(:) + swdown(:)
+!!$       ENDIF
+          
+       do_watch = .FALSE.
+       call isittime &
+            &  (itau_sechiba,date0_shifted,xrdt,dt_watch,&
+            &   last_action_watch,last_check_watch,do_watch)
+       last_check_watch = itau_sechiba
+       IF (do_watch) THEN
+          !
+          IF ( check ) WRITE(numout,*) 'save watchout'
+          !
+          IF (long_print) THEN
+             WRITE(numout,*) "intersurf : write watchout for date ",date0,date0_shifted,itau_sechiba, &
+                  & last_action_watch,last_check_watch
+          ENDIF
+          last_action_watch = itau_sechiba
+
+          sum_zlev(:) = sum_zlev(:) / dt_split_watch
+          sum_u(:) = sum_u(:) / dt_split_watch
+          sum_v(:) = sum_v(:) / dt_split_watch
+          sum_qair(:) = sum_qair(:) / dt_split_watch
+          sum_temp_air(:) = sum_temp_air(:) / dt_split_watch
+          sum_epot_air(:) = sum_epot_air(:) / dt_split_watch
+          sum_ccanopy(:) = sum_ccanopy(:) / dt_split_watch
+          sum_cdrag(:) = sum_cdrag(:) / dt_split_watch
+          sum_petAcoef(:) = sum_petAcoef(:) / dt_split_watch
+          sum_peqAcoef(:) = sum_peqAcoef(:) / dt_split_watch
+          sum_petBcoef(:) = sum_petBcoef(:) / dt_split_watch
+          sum_peqBcoef(:) = sum_peqBcoef(:) / dt_split_watch
+          sum_rain(:) = sum_rain(:) / dt_split_watch
+          sum_snow(:) = sum_snow(:) / dt_split_watch
+          sum_lwdown(:) = sum_lwdown(:) / dt_split_watch
+          sum_pb(:) = sum_pb(:) / dt_split_watch
+
+!!$          IF ( dt_watch > 3600 ) THEN 
+!!$             WHERE ( isinang(:,:) .GT. 0 )
+!!$                mean_sinang(:,:) = mean_sinang(:,:) / isinang(:,:)
+!!$             ENDWHERE
+!!$             !
+!!$             DO ik=1,kjpindex          
+!!$                j = ((kindex(ik)-1)/iim) + 1
+!!$                i = (kindex(ik) - (j-1)*iim)
+!!$                IF (mean_sinang(i,j) > zero) THEN
+!!$                   sum_swdown(ik) = sum_swdown(ik)/mean_sinang(i,j)
+!!$                   sum_swnet(ik) =  sum_swnet(ik)/mean_sinang(i,j)
+!!$                ELSE
+!!$                   sum_swdown(ik) = zero
+!!$                   sum_swnet(ik) =  zero
+!!$                ENDIF
+!!$             ENDDO
+!!$          ELSE
+             sum_swnet(:) = sum_swnet(:) / dt_split_watch
+             sum_swdown(:) = sum_swdown(:) / dt_split_watch
+!!$          ENDIF
+
+          CALL watchout_write_p(kjpindex, itau_sechiba, xrdt, sum_zlev, sum_swdown, sum_rain, &
+               &   sum_snow, sum_lwdown, sum_pb, sum_temp_air, sum_epot_air, sum_qair, &
+               &   sum_u, sum_v, sum_swnet, sum_petAcoef, sum_peqAcoef, sum_petBcoef, sum_peqBcoef, &
+               &   sum_cdrag, sum_ccanopy )
+       ENDIF       
+    ENDIF
+    !
+    ! 6. scatter output fields
+    !
+    z0(:)           = undef_sechiba
+    coastalflow(:)  = undef_sechiba
+    riverflow(:)    = undef_sechiba
+    tsol_rad(:)     = undef_sechiba
+    vevapp(:)       = undef_sechiba
+    temp_sol_new(:) = undef_sechiba
+    qsurf(:)        = undef_sechiba
+    albedo(:,1)     = undef_sechiba
+    albedo(:,2)     = undef_sechiba
+    fluxsens(:)     = undef_sechiba
+    fluxlat(:)      = undef_sechiba
+    emis(:)         = undef_sechiba
+    cdrag(:)        = undef_sechiba
+    !    
+!    dvevapp(:)    = undef_sechiba
+    dtemp_sol(:)  = undef_sechiba
+    dfluxsens(:)  = undef_sechiba
+    dfluxlat(:)   = undef_sechiba
+    dswnet (:)    = undef_sechiba
+    dswdown (:)   = undef_sechiba
+    dalbedo (:,1) = undef_sechiba
+    dalbedo (:,2) = undef_sechiba
+    dtair (:)     = undef_sechiba
+    dqair (:)     = undef_sechiba
+    dt2m (:)      = undef_sechiba
+    dq2m (:)      = undef_sechiba
+    !
+    DO ik=1, kjpindex
+       
+       z0(ik)           = zz0(ik)
+       coastalflow(ik)  = zcoastal(ik)/1000.
+       riverflow(ik)    = zriver(ik)/1000.
+       tsol_rad(ik)     = ztsol_rad(ik)
+       vevapp(ik)       = zvevapp(ik)
+       temp_sol_new(ik) = ztemp_sol_new(ik)
+       qsurf(ik)        = zqsurf(ik)
+       albedo(ik,1)     = zalbedo(ik,1)
+       albedo(ik,2)     = zalbedo(ik,2)
+       fluxsens(ik)     = zfluxsens(ik)
+       fluxlat(ik)      = zfluxlat(ik)
+       emis(ik)         = zemis(ik)
+       cdrag(ik)        = zcdrag(ik)
+       
+       ! Fill up the diagnostic arrays
+
+!       dvevapp(kindex(ik))    = zvevapp(ik)
+       dtemp_sol(kindex(ik))  = ztemp_sol_new(ik)
+       dfluxsens(kindex(ik))  = zfluxsens(ik)
+       dfluxlat(kindex(ik))   = zfluxlat(ik)
+       dswnet (kindex(ik))    = swnet(ik)
+       dswdown (kindex(ik))   = swdown(ik)
+       dalbedo (kindex(ik),1) = zalbedo(ik,1)
+       dalbedo (kindex(ik),2) = zalbedo(ik,2)   
+       dtair (kindex(ik))     = temp_air(ik)
+       dqair (kindex(ik))     = qair(ik)
+       dt2m (kindex(ik))      = t2m(ik)
+       dq2m (kindex(ik))      = q2m(ik)
+       !
+    ENDDO
+    !
+    ! Modified fields for variables scattered during the writing
+    !
+    dcoastal(:) = (zcoastal(:))/1000.
+    driver(:)   = (zriver(:))/1000.
+    !
+    IF ( .NOT. l_first_intersurf) THEN
+       !
+       IF ( .NOT. almaoutput ) THEN
+          !
+          !  scattered during the writing
+          !           
+          CALL histwrite (hist_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+          CALL histwrite (hist_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+          ! 
+          CALL histwrite (hist_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'fluxlat',  itau_sechiba, dfluxlat,  iim*jjm, kindex)
+          CALL histwrite (hist_id, 'swnet',    itau_sechiba, dswnet,    iim*jjm, kindex)
+          CALL histwrite (hist_id, 'swdown',   itau_sechiba, dswdown,   iim*jjm, kindex)
+          CALL histwrite (hist_id, 'alb_vis',  itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
+          CALL histwrite (hist_id, 'alb_nir',  itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
+          CALL histwrite (hist_id, 'tair',     itau_sechiba, dtair, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'qair',     itau_sechiba, dqair, iim*jjm, kindex)
+          CALL histwrite (hist_id, 't2m',      itau_sechiba, dq2m, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'q2m',      itau_sechiba, dt2m, iim*jjm, kindex)
+          !
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'evap',     itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'coastalflow',itau_sechiba, dcoastal, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'riverflow',itau_sechiba, driver, kjpindex, kindex)
+             ! 
+             CALL histwrite (hist2_id, 'temp_sol', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tsol_max', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tsol_min', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'fluxsens', itau_sechiba, dfluxsens, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'fluxlat',  itau_sechiba, dfluxlat,  iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'swnet',    itau_sechiba, dswnet,    iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'swdown',   itau_sechiba, dswdown,   iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'alb_vis',  itau_sechiba, dalbedo(:,1), iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'alb_nir',  itau_sechiba, dalbedo(:,2), iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'tair',     itau_sechiba, dtair, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'qair',     itau_sechiba, dqair, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 't2m',      itau_sechiba, dq2m, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'q2m',      itau_sechiba, dt2m, iim*jjm, kindex)
+          ENDIF
+       ELSE
+          CALL histwrite (hist_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+          CALL histwrite (hist_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'Qle',  itau_sechiba, dfluxlat, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          CALL histwrite (hist_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          !
+          IF ( hist2_id > 0 ) THEN
+             CALL histwrite (hist2_id, 'Evap', itau_sechiba, zvevapp, kjpindex, kindex)
+             CALL histwrite (hist2_id, 'SWnet',    itau_sechiba, dswnet, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'Qh', itau_sechiba, dfluxsens, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'Qle',  itau_sechiba, dfluxlat, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'AvgSurfT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+             CALL histwrite (hist2_id, 'RadT', itau_sechiba, dtemp_sol, iim*jjm, kindex)
+          ENDIF
+       ENDIF
+       !
+       IF (dw .EQ. xrdt) THEN
+          CALL histsync(hist_id)
+       ENDIF
+    !
+    ENDIF
+    !
+    ! 7. Transform the water fluxes into Kg/m^2s and m^3/s
+    !
+    DO ik=1, kjpindex
+
+       vevapp(ik) = vevapp(ik)/xrdt
+       coastalflow(ik) = coastalflow(ik)/xrdt
+       riverflow(ik) = riverflow(ik)/xrdt
+
+    ENDDO
+    !
+    IF ( lrestart_write .AND. ok_watchout .AND. is_root_prc ) THEN
+       CALL watchout_close()
+    ENDIF
+    !
+    IF(l_first_intersurf .AND. is_root_prc) CALL getin_dump
+    l_first_intersurf = .FALSE.
+    !
+    IF (long_print) WRITE (numout,*) ' intersurf_main done '
+    !
+    CALL ipslnlf(new_number=old_fileout)
+    !        
+  END SUBROUTINE intersurf_gathered_2m
+!
+  !-------------------------------------------------------------------------------------
+  !
+  SUBROUTINE intsurf_time(istp, date0, dt)
+    !
+    !  This subroutine initialized the time global variables in grid module.
+    !
+    IMPLICIT NONE
+    !
+    INTEGER(i_std), INTENT(in)                  :: istp      !! Time step of the restart file
+    REAL(r_std), INTENT(in)                     :: date0     !! The date at which itau = 0
+    REAL(r_std), INTENT(in)                     :: dt        !! Time step
+    !
+    ! LOCAL
+    LOGICAL     :: check=.FALSE.
+
+    IF (l_first_intersurf) THEN
+       CALL ioget_calendar(calendar_str)
+       CALL ioget_calendar(one_year, one_day)
+       CALL tlen2itau('1Y',dt,date0,year_length)
+       IF ( TRIM(calendar_str) .EQ. 'gregorian' ) THEN  
+          year_spread=un
+       ELSE
+          year_spread = one_year/365.2425
+       ENDIF
+
+       IF (check) THEN
+          write(numout,*) "calendar_str =",calendar_str
+          write(numout,*) "one_year=",one_year,", one_day=",one_day
+          write(numout,*) "dt=",dt,", date0=",date0,", year_length=",year_length,", year_spread=",year_spread
+       ENDIF
+    ENDIF
+
+    !
+    IF (check) &
+         WRITE(numout,*) "---" 
+    ! Dans diffuco (ie date0 == date0_shift !!) 
+
+    IF ( TRIM(calendar_str) .EQ. 'gregorian' ) THEN  
+       !
+       ! Get Julian date
+       in_julian = itau2date(istp, date0, dt)
+
+       ! Real date
+       CALL ju2ymds (in_julian, year, month, day, sec)
+!!$       jur=zero
+!!$       julian_diff = in_julian
+!!$       month_len = ioget_mon_len (year,month)
+!!$       IF (check) THEN
+!!$          write(numout,*) "in_julian, jur, julian_diff=",in_julian, jur, julian_diff
+!!$          write(numout,*) 'DATE ymds', year, month,'(',month_len,'d)', day, sec, '-- stp --', istp
+!!$       ENDIF
+
+       ! julian number for january, the first.
+       CALL ymds2ju (year,1,1,zero, julian0)
+       julian_diff = in_julian-julian0
+       ! real number of seconds
+!       sec = (julian_diff-REAL(INT(julian_diff)))*one_day
+       sec = NINT((julian_diff-REAL(INT(julian_diff)))*one_day)
+       month_len = ioget_mon_len (year,month)
+       IF (check) THEN
+          write(numout,*) "2 in_julian, julian0, julian_diff=",in_julian, julian0, julian_diff
+          write(numout,*) '2 DATE ymds', year, month,'(',month_len,'d)', day, sec, '-- stp --', istp
+       ENDIF
+    ELSE 
+!!$       in_julian = itau2date(istp-1, zero, dt)
+!!$       CALL ju2ymds (in_julian, year, month, day, sec)
+!!$       jur=zero
+!!$       julian_diff = in_julian
+!!$       month_len = ioget_mon_len (year,month)
+!!$       IF (check) THEN
+!!$          write(numout,*) "in_julian=",in_julian, jur, julian_diff
+!!$          write(numout,*) 'DATE ymds', year, month,'(',month_len,'d)', day, sec, '-- stp --', istp
+!!$       ENDIF
+!!$
+!!$
+!!$       CALL ymds2ju (year,1,1,zero, jur)
+!!$       julian_diff = in_julian-jur
+!!$       CALL ju2ymds (julian_diff, year, month, day, sec)
+!!$!       sec = (julian_diff-REAL(INT(julian_diff)))*one_day
+!!$       sec = NINT((julian_diff-REAL(INT(julian_diff)))*one_day)
+!!$       month_len = ioget_mon_len (year,month)
+!!$       IF (check) THEN
+!!$          write(numout,*) "2 in_julian, jur, julian_diff=",in_julian, jur, julian_diff
+!!$          write(numout,*) '2 DATE ymds', year, month,'(',month_len,'d)', day, sec, '-- stp --', istp
+!!$       ENDIF
+
+
+!!$       IF (check) &
+!!$            WRITE(numout,*) "-"
+
+!MM
+!PB date0 = celui de Soenke (Ã  tester avec un autre date0)
+!       in_julian = itau2date(istp, 153116., dt)
+       in_julian = itau2date(istp, date0, dt)
+       CALL itau2ymds(istp, dt, year, month, day, sec)
+       CALL ymds2ju (year,1,1,zero, julian0)
+       julian_diff = in_julian
+       month_len = ioget_mon_len (year,month)
+       IF (check) THEN
+          write(numout,*) "in_julian=",in_julian, julian0, julian_diff
+          write(numout,*) 'DATE ymds', year, month,'(',month_len,'d)', day, sec, '-- stp --', istp
+       ENDIF
+    ENDIF
+!!$    IF (check) &
+!!$         WRITE(numout,*) "---" 
+
+  END SUBROUTINE intsurf_time
+!
+
+!-------------------------------------------------------------------------------------
+!
+  SUBROUTINE intsurf_config(control_flags,dt)
+    !
+    !  This subroutine reads all the configuration flags which control the behaviour of the model
+    !
+    IMPLICIT NONE
+    !
+    REAL, INTENT(in)                           :: dt            !! Time step in seconds
+    !
+    TYPE(control_type), INTENT(out)            :: control_flags !! Flags that (de)activate parts of the model
+
+    !
+    !Config Key  = LONGPRINT
+    !Config Desc = ORCHIDEE will print more messages
+    !Config Def  = n
+    !Config Help = This flag permits to print more debug messages in the run.
+    !
+    long_print = .FALSE.
+    CALL getin_p('LONGPRINT',long_print)
+    !
+    !
+    !Config Key  = ORCHIDEE_WATCHOUT
+    !Config Desc = ORCHIDEE will write out its forcing to a file
+    !Config Def  = n
+    !Config Help = This flag allows to write to a file all the variables
+    !Config        which are used to force the land-surface. The file 
+    !Config        has exactly the same format than a normal off-line forcing
+    !Config        and thus this forcing can be used for forcing ORCHIDEE.
+    !
+    ok_watchout = .FALSE.
+    CALL getin_p('ORCHIDEE_WATCHOUT',ok_watchout)
+    !
+    IF (ok_watchout) THEN
+       !Config Key  = DT_WATCHOUT
+       !Config Desc = ORCHIDEE will write out with this frequency
+       !Config IF   = ORCHIDEE_WATCHOUT
+       !Config Def  = dt
+       !Config Help = This flag indicates the frequency of the write of the variables. 
+       !
+       dt_watch = dt
+       CALL getin_p('DT_WATCHOUT',dt_watch)
+       dt_split_watch = dt_watch / dt
+       !
+       !Config Key  = WATCHOUT_FILE
+       !Config Desc = Filenane for the ORCHIDEE forcing file
+       !Config IF   = ORCHIDEE_WATCHOUT
+       !Config Def  = orchidee_watchout.nc
+       !Config Help = This is the name of the file in which the
+       !Config        forcing used here will be written for later use. 
+       !
+       watchout_file = "orchidee_watchout.nc"
+       CALL getin_p('WATCHOUT_FILE',watchout_file)
+       
+       WRITE(numout,*) 'WATCHOUT flag :', ok_watchout
+       WRITE(numout,*) 'WATCHOUT file :', watchout_file
+    ENDIF
+    !
+    !Config Key  = RIVER_ROUTING
+    !Config Desc = Decides if we route the water or not
+    !Config Def  = n
+    !Config Help = This flag allows the user to decide if the runoff
+    !Config        and drainage should be routed to the ocean
+    !Config        and to downstream grid boxes.
+    !
+    control_flags%river_routing = .FALSE.
+    CALL getin_p('RIVER_ROUTING', control_flags%river_routing)
+    WRITE(numout,*) "RIVER routing is activated : ",control_flags%river_routing
+    !
+    !Config key = HYDROL_CWRR
+    !Config Desc = Allows to switch on the multilayer hydrology of CWRR
+    !Config Def  = n
+    !Config Help = This flag allows the user to decide if the vertical
+    !Config        hydrology should be treated using the multi-layer 
+    !Config        diffusion scheme adapted from CWRR by Patricia de Rosnay.
+    !Config        by default the Choisnel hydrology is used.
+    !
+    control_flags%hydrol_cwrr = .FALSE.
+    CALL getin_p('HYDROL_CWRR', control_flags%hydrol_cwrr)
+    IF ( control_flags%hydrol_cwrr ) then
+       CALL ipslerr (2,'intsurf_config', &
+            &          'You will use in this run the second version of CWRR hydrology in ORCHIDEE.',&
+            &          'This model hasn''t been tested for global run yet.', &
+            &          '(check your parameters)')
+    ENDIF
+    !
+    !Config Key  = STOMATE_OK_CO2
+    !Config Desc = Activate CO2?
+    !Config Def  = n
+    !Config Help = set to TRUE if photosynthesis is to be activated
+    !
+    control_flags%ok_co2 = .FALSE.
+    CALL getin_p('STOMATE_OK_CO2', control_flags%ok_co2)
+    WRITE(numout,*) 'photosynthesis: ', control_flags%ok_co2
+    !
+    !Config Key  = STOMATE_OK_STOMATE
+    !Config Desc = Activate STOMATE?
+    !Config Def  = n
+    !Config Help = set to TRUE if STOMATE is to be activated
+    !
+    control_flags%ok_stomate = .FALSE.
+    CALL getin_p('STOMATE_OK_STOMATE',control_flags%ok_stomate)
+    WRITE(numout,*) 'STOMATE is activated: ',control_flags%ok_stomate
+    !
+    !Config Key  = STOMATE_OK_DGVM
+    !Config Desc = Activate DGVM?
+    !Config Def  = n
+    !Config Help = set to TRUE if DGVM is to be activated
+    !
+    control_flags%ok_dgvm = .FALSE.
+    CALL getin_p('STOMATE_OK_DGVM',control_flags%ok_dgvm)
+
+    IF ( control_flags%ok_dgvm ) THEN
+       WRITE(numout,*) 'You try to use LPJ ',control_flags%ok_dgvm, &
+            ' with this version. '
+       WRITE(numout,*) 'It is not possible because it has to be modified ', &
+            ' to give correct values.'
+       CALL ipslerr (3,'intsurf_config', &
+         &          'Use of STOMATE_OK_DGVM not allowed with this version.',&
+         &          'ORCHIDEE will stop.', &
+         &          'Please disable DGVM to use this version of ORCHIDEE.')
+    ENDIF
+    !
+    ! control initialisation with sechiba
+    !
+    control_flags%ok_sechiba = .TRUE.
+    !
+    !
+    ! Ensure consistency
+    !
+    IF ( control_flags%ok_dgvm ) control_flags%ok_stomate = .TRUE.
+    IF ( control_flags%ok_stomate ) control_flags%ok_co2 = .TRUE.
+    !
+    !Config Key  = STOMATE_WATCHOUT
+    !Config Desc = STOMATE does minimum service
+    !Config Def  = n
+    !Config Help = set to TRUE if you want STOMATE to read
+    !Config        and write its start files and keep track
+    !Config        of longer-term biometeorological variables.
+    !Config        This is useful if OK_STOMATE is not set,
+    !Config        but if you intend to activate STOMATE later.
+    !Config        In that case, this run can serve as a 
+    !Config        spinup for longer-term biometeorological
+    !Config        variables.
+    !
+    control_flags%stomate_watchout = .FALSE.
+    CALL getin_p('STOMATE_WATCHOUT',control_flags%stomate_watchout)
+    WRITE(numout,*) 'STOMATE keeps an eye open: ',control_flags%stomate_watchout
+    !
+    ! Here we need the same initialisation as above
+    !
+    control_flags%ok_pheno = .TRUE.
+    !
+    !
+    RETURN
+    !
+  END SUBROUTINE intsurf_config
+  !
+  !
+  !
+  SUBROUTINE intsurf_restart(istp, iim, jjm, lon, lat, date0, dt, control_flags, rest_id, rest_id_stom, itau_offset)
+    !
+    !  This subroutine initialized the restart file for the land-surface scheme
+    !
+    IMPLICIT NONE
+    !
+    INTEGER(i_std), INTENT(in)                  :: istp      !! Time step of the restart file
+    INTEGER(i_std), INTENT(in)                  :: iim, jjm  !! Size in x and y of the data to be handeled
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: lon, lat  !! Logitude and latitude of the data points
+    REAL(r_std)                                 :: date0     !! The date at which itau = 0
+    REAL(r_std)                                 :: dt        !! Time step
+    INTEGER(i_std), INTENT(out)                 :: rest_id, rest_id_stom   !! ID of the restart file
+    INTEGER(i_std), INTENT(out)                 :: itau_offset
+    !
+    TYPE(control_type), INTENT(in)             :: control_flags !! Flags that (de)activate parts of the model
+    !
+    !  LOCAL
+    !
+    CHARACTER(LEN=80)          :: restname_in, restname_out, stom_restname_in, stom_restname_out
+    REAL(r_std)                 :: dt_rest, date0_rest
+    INTEGER(i_std)              :: itau_dep
+    INTEGER(i_std),PARAMETER    :: llm=1
+    REAL(r_std), DIMENSION(llm) :: lev
+    LOGICAL                    :: overwrite_time
+    REAL(r_std)                 :: in_julian, rest_julian
+    INTEGER(i_std)              :: yy, mm, dd
+    REAL(r_std)                 :: ss
+    !
+    !Config  Key  = SECHIBA_restart_in
+    !Config  Desc = Name of restart to READ for initial conditions
+    !Config  Def  = NONE
+    !Config  Help = This is the name of the file which will be opened
+    !Config         to extract the initial values of all prognostic
+    !Config         values of the model. This has to be a netCDF file.
+    !Config         Not truly COADS compliant. NONE will mean that
+    !Config         no restart file is to be expected.
+!-
+    restname_in = 'NONE'
+    CALL getin_p('SECHIBA_restart_in',restname_in)
+    WRITE(numout,*) 'INPUT RESTART_FILE', restname_in
+    !-
+    !Config Key  = SECHIBA_rest_out
+    !Config Desc = Name of restart files to be created by SECHIBA
+    !Config Def  = sechiba_rest_out.nc
+    !Config Help = This variable give the name for
+    !Config        the restart files. The restart software within
+    !Config        IOIPSL will add .nc if needed.
+    !
+    restname_out = 'restart_out.nc'
+    CALL getin_p('SECHIBA_rest_out', restname_out)
+    !
+    !Config Key  = SECHIBA_reset_time
+    !Config Desc = Option to overrides the time of the restart
+    !Config Def  = n
+    !Config Help = This option allows the model to override the time
+    !Config        found in the restart file of SECHIBA with the time
+    !Config        of the first call. That is the restart time of the GCM.
+    !
+    overwrite_time = .FALSE.
+    CALL getin_p('SECHIBA_reset_time', overwrite_time)
+    !
+    lev(:) = zero
+    itau_dep = istp
+    in_julian = itau2date(istp, date0, dt)
+    date0_rest = date0
+    dt_rest = dt
+    !
+    IF (is_root_prc) THEN
+      CALL restini( restname_in, iim_g, jjm_g, lon_g, lat_g, llm, lev, &
+         &  restname_out, itau_dep, date0_rest, dt_rest, rest_id, overwrite_time)
+    ELSE
+       rest_id=0
+    ENDIF
+    CALL bcast (itau_dep)
+    CALL bcast (date0_rest)
+    CALL bcast (dt_rest)
+    !
+    !  itau_dep of SECHIBA is phased with the GCM if needed
+    !
+    rest_julian = itau2date(itau_dep, date0_rest, dt_rest)
+    !
+    IF ( ABS( in_julian - rest_julian) .GT. dt/one_day .AND. .NOT. OFF_LINE_MODE ) THEN
+       IF ( overwrite_time ) THEN
+          WRITE(numout,*) 'The SECHIBA restart is not for the same timestep as the GCM,'
+          WRITE(numout,*) 'the two are synchronized. The land-surface conditions can not impose'
+          WRITE(numout,*) 'the chronology of the simulation.'
+          WRITE(numout,*) 'Time step of the GCM :', istp, 'Julian day : ', in_julian
+          CALL ju2ymds(in_julian, yy, mm, dd, ss)
+          WRITE(numout,*) 'In other word (yy,mm,dd,ss) : ', yy, mm, dd, ss
+          WRITE(numout,*) 'Time step of SECHIBA :', itau_dep, 'Julian day : ', rest_julian
+          CALL ju2ymds(rest_julian, yy, mm, dd, ss)
+          WRITE(numout,*) 'In other word (yy,mm,dd,ss) : ', yy, mm, dd, ss
+
+          itau_offset = itau_dep - istp
+          date0_shifted = date0 - itau_offset*dt/one_day
+!MM_ A VOIR : dans le TAG 1.4 :
+!         date0_shifted = in_julian - itau_dep*dt/one_day
+!MM_ Bon calcul ?
+
+          WRITE(numout,*) 'The new starting date is :', date0_shifted
+          CALL ju2ymds(date0_shifted, yy, mm, dd, ss)
+          WRITE(numout,*) 'In other word (yy,mm,dd,ss) : ', yy, mm, dd, ss
+       ELSE
+          WRITE(numout,*) 'IN -> OUT :', istp, '->', itau_dep
+          WRITE(numout,*) 'IN -> OUT :', in_julian, '->', rest_julian
+          WRITE(numout,*) 'SECHIBA''s restart file is not consistent with the one of the GCM'
+          WRITE(numout,*) 'Correct the time axis of the restart file or force the code to change it.'
+          STOP
+       ENDIF
+    ELSE
+       itau_offset = 0
+       date0_shifted = date0
+    ENDIF
+    !
+!!!    CALL ioconf_startdate(date0_shifted)
+    !
+    !=====================================================================
+    !- 1.5 Restart file for STOMATE
+    !=====================================================================
+    IF ( control_flags%ok_stomate .OR. control_flags%stomate_watchout ) THEN 
+       !-
+       ! STOMATE IS ACTIVATED
+       !-
+       !Config  Key  = STOMATE_RESTART_FILEIN
+       !Config  Desc = Name of restart to READ for initial conditions
+       !Config         of STOMATE
+       !Config  If   = STOMATE_OK_STOMATE || STOMATE_WATCHOUT
+       !Config  Def  = NONE
+       !Config  Help = This is the name of the file which will be opened
+       !Config         to extract the initial values of all prognostic
+       !Config         values of STOMATE.
+       !-
+       stom_restname_in = 'NONE'
+       CALL getin_p('STOMATE_RESTART_FILEIN',stom_restname_in)
+       WRITE(numout,*) 'STOMATE INPUT RESTART_FILE', stom_restname_in
+       !-
+       !Config Key  = STOMATE_RESTART_FILEOUT
+       !Config Desc = Name of restart files to be created by STOMATE
+       !Config  If   = STOMATE_OK_STOMATE || STOMATE_WATCHOUT
+       !Config Def  = stomate_restart.nc
+       !Config Help = This is the name of the file which will be opened
+       !Config        to write the final values of all prognostic values
+       !Config        of STOMATE.
+       !-
+       stom_restname_out = 'stomate_restart.nc'
+       CALL getin_p('STOMATE_RESTART_FILEOUT', stom_restname_out)
+       WRITE(numout,*) 'STOMATE OUTPUT RESTART_FILE', stom_restname_out
+       !-
+       IF (is_root_prc) THEN
+         CALL restini (stom_restname_in, iim_g, jjm_g, lon_g, lat_g, llm, lev, &
+            &  stom_restname_out, itau_dep, date0_rest, dt_rest, rest_id_stom, overwrite_time)
+       ELSE
+         rest_id_stom=0
+       ENDIF
+       CALL bcast (itau_dep)
+       CALL bcast (date0_rest)
+       CALL bcast (dt_rest)
+       !-
+    ENDIF
+    !
+  END SUBROUTINE intsurf_restart
+  
+  SUBROUTINE intsurf_history(iim, jjm, lon, lat, istp_old, date0, dt, control_flags, hist_id, hist2_id, &
+       & hist_id_stom, hist_id_stom_IPCC)
+    !
+    !   
+    !  This subroutine initialized the history files for the land-surface scheme
+    !
+    IMPLICIT NONE
+    !
+    INTEGER(i_std), INTENT(in)                  :: iim, jjm  !! Size in x and y of the data to be handeled
+    REAL(r_std),DIMENSION (iim,jjm), INTENT(in) :: lon, lat  !! Longitude and latitude of the data points
+    INTEGER(i_std), INTENT(in)                  :: istp_old  !! Time step counter
+    REAL(r_std), INTENT(in)                     :: date0     !! Julian day at which istp=0
+    REAL(r_std), INTENT(in)                     :: dt        !! Time step of the counter in seconds
+    !
+    TYPE(control_type), INTENT(in)             :: control_flags !! Flags that (de)activate parts of the model
+    !
+    INTEGER(i_std), INTENT(out)                 :: hist_id !! History file identification for SECHIBA
+    INTEGER(i_std), INTENT(out)                 :: hist2_id !! History file 2 identification for SECHIBA (Hi-frequency ?)
+    !! History file identification for STOMATE and IPCC
+    INTEGER(i_std), INTENT(out)                 :: hist_id_stom, hist_id_stom_IPCC 
+    !
+    !  LOCAL
+    !
+    CHARACTER(LEN=80) :: histname,histname2                    !! Name of history files for SECHIBA
+    CHARACTER(LEN=80) :: stom_histname, stom_ipcc_histname     !! Name of history files for STOMATE
+    LOGICAL           :: ok_histfile2                 !! Flag to switch on histfile 2 for SECHIBA
+    REAL(r_std)       :: dw2                          !! frequency of history write (sec.)
+    CHARACTER(LEN=30)   :: flux_op                    !! Operations to be performed on fluxes
+    CHARACTER(LEN=30)   :: flux_sc                    !! Operations which do not include a scatter
+    CHARACTER(LEN=30)   :: flux_insec, flux_scinsec   !! Operation in seconds
+    INTEGER(i_std)     :: hist_level, hist2_level     !! history output level (default is 10 => maximum output)
+    CHARACTER(LEN=40),DIMENSION(max_hist_level) :: &
+         & ave, avecels, avescatter, fluxop, &
+         & fluxop_scinsec, tmincels, tmaxcels, once, sumscatter  !! The various operation to be performed
+!!, tmax, fluxop_sc, fluxop_insec, &
+    CHARACTER(LEN=40),DIMENSION(max_hist_level) :: &
+         & ave2, avecels2, avescatter2, fluxop2, &
+         & fluxop_scinsec2, tmincels2, tmaxcels2, once2, sumscatter2  !! The various operation to be performed
+!!, tmax2, fluxop_sc2, fluxop_insec2, &
+    INTEGER(i_std)     :: i, jst
+    ! SECHIBA AXIS
+    INTEGER(i_std)     :: hori_id                      !! ID of the default horizontal longitude and latitude map.
+    INTEGER(i_std)     :: vegax_id, solax_id, soltax_id, nobioax_id !! ID's for two vertical coordinates
+    INTEGER(i_std)     :: solayax_id                   !! ID for the vertical axis of the CWRR hydrology 
+    INTEGER(i_std)     :: hori_id2                      !! ID of the default horizontal longitude and latitude map.
+    INTEGER(i_std)     :: vegax_id2, solax_id2, soltax_id2, nobioax_id2, albax_id2 !! ID's for two vertical coordinates
+    INTEGER(i_std)     :: solayax_id2                   !! ID for the vertical axis of the CWRR hydrology 
+    ! STOMATE AXIS
+    INTEGER(i_std)     :: hist_PFTaxis_id
+! deforestation
+    INTEGER(i_std)     :: hist_pool_10axis_id
+    INTEGER(i_std)     :: hist_pool_100axis_id
+    INTEGER(i_std)     :: hist_pool_11axis_id
+    INTEGER(i_std)     :: hist_pool_101axis_id
+    ! STOMATE IPCC AXIS
+    INTEGER(i_std)     :: hist_IPCC_PFTaxis_id
+    !
+    LOGICAL                               :: rectilinear
+    INTEGER(i_std)                         :: ier
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_rect, lat_rect
+    !
+    REAL(r_std),DIMENSION(nvm)   :: veg
+    REAL(r_std),DIMENSION(ngrnd) :: sol
+    REAL(r_std),DIMENSION(nstm)  :: soltyp
+    REAL(r_std),DIMENSION(nnobio):: nobiotyp
+    REAL(r_std),DIMENSION(2)     :: albtyp
+    REAL(r_std),DIMENSION(nslm)  :: solay
+    !
+    CHARACTER(LEN=80)           :: var_name           !! To store variables names
+    !
+    ! STOMATE history file
+    REAL(r_std)                  :: hist_days_stom     !!- GK time step in days for this history file
+    REAL(r_std)                  :: hist_dt_stom       !!- GK time step in seconds for this history file
+    REAL(r_std)                  :: dt_slow_           !!  for test : time step of slow processes and STOMATE
+    REAL(r_std),DIMENSION(nvm)   :: hist_PFTaxis       !!- GK An axis we need for the history files
+!
+    REAL(r_std),DIMENSION(10)  :: hist_pool_10axis     !! Deforestation axis
+    REAL(r_std),DIMENSION(100)  :: hist_pool_100axis     !! Deforestation axis
+    REAL(r_std),DIMENSION(11)  :: hist_pool_11axis     !! Deforestation axis
+    REAL(r_std),DIMENSION(101)  :: hist_pool_101axis     !! Deforestation axis
+    !
+    ! IPCC history file
+    REAL(r_std)                  :: hist_days_stom_ipcc     !!- GK time step in days for this history file
+    REAL(r_std)                  :: hist_dt_stom_ipcc       !!- GK time step in seconds for this history file
+!
+    !
+    !
+    !=====================================================================
+    !- 3.0 Setting up the history files
+    !=====================================================================
+    !- 3.1 SECHIBA
+    !=====================================================================
+    !Config  Key  = ALMA_OUTPUT
+    !Config  Desc = Should the output follow the ALMA convention
+    !Config  Def  = n
+    !Config  Help = If this logical flag is set to true the model
+    !Config         will output all its data according to the ALMA 
+    !Config         convention. It is the recommended way to write
+    !Config         data out of ORCHIDEE.
+    !-
+    almaoutput = .FALSE.
+    CALL getin_p('ALMA_OUTPUT', almaoutput)    
+    WRITE(numout,*) 'ALMA_OUTPUT', almaoutput
+    !-
+    !Config  Key  = OUTPUT_FILE
+    !Config  Desc = Name of file in which the output is going
+    !Config         to be written
+    !Config  Def  = cabauw_out.nc
+    !Config  Help = This file is going to be created by the model
+    !Config         and will contain the output from the model.
+    !Config         This file is a truly COADS compliant netCDF file.
+    !Config         It will be generated by the hist software from
+    !Config         the IOIPSL package.
+    !-
+    histname='cabauw_out.nc'
+    CALL getin_p('OUTPUT_FILE', histname)
+    WRITE(numout,*) 'OUTPUT_FILE', histname
+    !-
+    !Config  Key  = WRITE_STEP
+    !Config  Desc = Frequency in seconds at which to WRITE output
+    !Config  Def  = one_day
+    !Config  Help = This variables gives the frequency the output of
+    !Config         the model should be written into the netCDF file.
+    !Config         It does not affect the frequency at which the
+    !Config         operations such as averaging are done.
+    !Config         That is IF the coding of the calls to histdef
+    !Config         are correct !
+    !-
+    dw = one_day
+    CALL getin_p('WRITE_STEP', dw)
+    !
+    veg(1:nvm)   = (/ (REAL(i,r_std),i=1,nvm) /)
+    sol(1:ngrnd) = (/ (REAL(i,r_std),i=1,ngrnd) /)   
+    soltyp(1:nstm) = (/ (REAL(i,r_std),i=1,nstm) /)
+    nobiotyp(1:nnobio) = (/ (REAL(i,r_std),i=1,nnobio) /)
+    albtyp(1:2) = (/ (REAL(i,r_std),i=1,2) /)
+    solay(1:nslm) = (/ (REAL(i,r_std),i=1,nslm) /)
+    !
+    !- We need to flux averaging operation as when the data is written
+    !- from within SECHIBA a scatter is needed. In the driver on the other
+    !- hand the data is 2D and can be written is it is.
+    !-
+    WRITE(flux_op,'("ave(scatter(X*",F8.1,"))")') one_day/dt
+    ! WRITE(flux_op,'("(ave(scatter(X))*",F8.1,")")') one_day/dt
+    WRITE(flux_sc,'("ave(X*",F8.1,")")') one_day/dt
+    !WRITE(flux_sc,'("(ave(X)*",F8.1,")")') one_day/dt
+    WRITE(flux_insec,'("ave(X*",F8.6,")")') un/dt
+    WRITE(flux_scinsec,'("ave(scatter(X*",F8.6,"))")') un/dt
+    WRITE(numout,*) flux_op, one_day/dt, dt, dw
+    !-
+    !Config  Key  = SECHIBA_HISTLEVEL
+    !Config  Desc = SECHIBA history output level (0..10)
+    !Config  Def  = 5
+    !Config  Help = Chooses the list of variables in the history file. 
+    !Config         Values between 0: nothing is written; 10: everything is 
+    !Config         written are available More details can be found on the web under documentation.
+    !Config         web under documentation.
+    !-
+    hist_level = 5
+    CALL getin_p('SECHIBA_HISTLEVEL', hist_level)
+    !-
+    WRITE(numout,*) 'SECHIBA history level: ',hist_level
+    IF ( (hist_level > max_hist_level).OR.(hist_level < 0) ) THEN
+       STOP 'This history level is not allowed'
+    ENDIF
+    !-
+    !- define operations as a function of history level.
+    !- Above hist_level, operation='never'
+    !-
+    ave(1:max_hist_level) = 'ave(X)'
+    IF (hist_level < max_hist_level) THEN
+       ave(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    sumscatter(1:max_hist_level) = 't_sum(scatter(X))'
+    IF (hist_level < max_hist_level) THEN
+       sumscatter(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    avecels(1:max_hist_level) = 'ave(cels(X))'
+    IF (hist_level < max_hist_level) THEN
+       avecels(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    avescatter(1:max_hist_level) = 'ave(scatter(X))'
+    IF (hist_level < max_hist_level) THEN
+       avescatter(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    tmincels(1:max_hist_level) = 't_min(cels(X))'
+    IF (hist_level < max_hist_level) THEN
+       tmincels(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    tmaxcels(1:max_hist_level) = 't_max(cels(X))'
+    IF (hist_level < max_hist_level) THEN
+       tmaxcels(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+!!$    tmax(1:max_hist_level) = 't_max(X)'
+!!$    IF (hist_level < max_hist_level) THEN
+!!$       tmax(hist_level+1:max_hist_level) = 'never'
+!!$    ENDIF
+    fluxop(1:max_hist_level) = flux_op
+    IF (hist_level < max_hist_level) THEN
+       fluxop(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+!!$    fluxop_sc(1:max_hist_level) = flux_sc
+!!$    IF (hist_level < max_hist_level) THEN
+!!$       fluxop_sc(hist_level+1:max_hist_level) = 'never'
+!!$    ENDIF
+!!$    fluxop_insec(1:max_hist_level) = flux_insec
+!!$    IF (hist_level < max_hist_level) THEN
+!!$       fluxop_insec(hist_level+1:max_hist_level) = 'never'
+!!$    ENDIF
+    fluxop_scinsec(1:max_hist_level) = flux_scinsec
+    IF (hist_level < max_hist_level) THEN
+       fluxop_scinsec(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    once(1:max_hist_level) = 'once(scatter(X))'
+    IF (hist_level < max_hist_level) THEN
+       once(hist_level+1:max_hist_level) = 'never'
+    ENDIF
+    ! 
+    !-
+    !- Check if we have by any change a rectilinear grid. This would allow us to 
+    !- simplify the output files.
+    !
+    rectilinear = .FALSE.
+    IF ( ALL(lon(:,:) == SPREAD(lon(:,1), 2, SIZE(lon,2))) .AND. &
+       & ALL(lat(:,:) == SPREAD(lat(1,:), 1, SIZE(lat,1))) ) THEN
+       rectilinear = .TRUE.
+       ALLOCATE(lon_rect(iim),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in lon_rect allocation. We stop. We need iim words = ',iim
+          STOP 'intersurf_history'
+       ENDIF
+       ALLOCATE(lat_rect(jjm),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in lat_rect allocation. We stop. We need jjm words = ',jjm
+          STOP 'intersurf_history'
+       ENDIF
+       lon_rect(:) = lon(:,1)
+       lat_rect(:) = lat(1,:)
+    ENDIF
+    !-
+    !-
+    hist_id = -1
+    !-
+    IF ( .NOT. almaoutput ) THEN
+       !- 
+       IF ( rectilinear ) THEN
+#ifdef CPP_PARA
+          CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id,orch_domain_id)
+#else
+          CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id)
+#endif
+          WRITE(numout,*)  'HISTBEG --->',istp_old,date0,dt,dw,hist_id
+       ELSE
+#ifdef CPP_PARA
+          CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+	       &     istp_old, date0, dt, hori_id, hist_id,domain_id=orch_domain_id)
+#else
+          CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id)
+#endif
+       ENDIF
+       !-
+       CALL histvert(hist_id, 'veget', 'Vegetation types', '1', &
+            &    nvm,   veg, vegax_id)
+       CALL histvert(hist_id, 'solth', 'Soil levels',      'm', &
+            &    ngrnd, sol, solax_id)
+       CALL histvert(hist_id, 'soiltyp', 'Soil types',      '1', &
+            &    nstm, soltyp, soltax_id)
+       CALL histvert(hist_id, 'nobio', 'Other surface types',      '1', &
+            &    nnobio, nobiotyp, nobioax_id)
+       IF (  control_flags%hydrol_cwrr ) THEN
+          CALL histvert(hist_id, 'solay', 'Hydrol soil levels',      'm', &
+               &    nslm, solay, solayax_id)
+       ENDIF
+       !-
+       !- SECHIBA_HISTLEVEL = 1
+       !-
+       CALL histdef(hist_id, 'evap', 'Evaporation', 'mm/d', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
+       CALL histdef(hist_id, 'coastalflow', 'Diffuse coastal flow', 'm^3/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'riverflow', 'River flow to the oceans', 'm^3/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw) 
+       CALL histdef(hist_id, 'temp_sol', 'Surface Temperature', 'C', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avecels(1), dt,dw)
+       CALL histdef(hist_id, 'rain', 'Rainfall', 'mm/d',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
+       CALL histdef(hist_id, 'snowf', 'Snowfall', 'mm/d',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(1), dt,dw)
+       CALL histdef(hist_id, 'netrad', 'Net radiation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'lai', 'Leaf Area Index', '1', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(1), dt,dw)
+       IF ( control_flags%river_routing ) THEN
+          CALL histdef(hist_id, 'basinmap', 'Aproximate map of the river basins', ' ', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw) 
+          CALL histdef(hist_id, 'nbrivers', 'Number or rivers in the outflow grid box', ' ', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)  
+       ENDIF
+       !-
+       !- SECHIBA_HISTLEVEL = 2
+       !-
+       CALL histdef(hist_id, 'subli', 'Sublimation', 'mm/d', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
+       CALL histdef(hist_id, 'evapnu', 'Bare soil evaporation', 'mm/d', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
+       CALL histdef(hist_id, 'runoff', 'Surface runoff', 'mm/d', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
+       CALL histdef(hist_id, 'drainage', 'Deep drainage', 'mm/d', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
+       IF ( control_flags%river_routing ) THEN
+          CALL histdef(hist_id, 'riversret', 'Return from endorheic rivers', 'mm/d', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(2), dt,dw)
+          CALL histdef(hist_id, 'hydrographs', 'Hydrographs of gridbox outflow', 'm^3/s', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(2), dt,dw)
+       ENDIF
+       IF ( control_flags%hydrol_cwrr ) THEN
+          CALL histdef(hist_id, 'evapnu_soil', 'Bare soil evap for soil type', 'mm/d', &
+               & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(2), dt,dw)
+          CALL histdef(hist_id, 'drainage_soil', 'Drainage for soil type', 'mm/d', &
+               & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(2), dt,dw)
+          CALL histdef(hist_id, 'transpir_soil', 'Transpir for soil type', 'mm/d', &
+               & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(2), dt,dw)
+          CALL histdef(hist_id, 'runoff_soil', 'Runoff for soil type', 'mm/d', &
+               & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, fluxop(2), dt,dw)
+       ENDIF
+       !
+       CALL histdef(hist_id, 'tair', 'Air Temperature', 'K',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+       CALL histdef(hist_id, 'qair', 'Air humidity', 'g/g',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+       ! Ajouts Nathalie - Juillet 2006
+       CALL histdef(hist_id, 'q2m', '2m Air humidity', 'g/g',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+       CALL histdef(hist_id, 't2m', '2m Air Temperature', 'K',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+       ! Fin ajouts Nathalie
+       CALL histdef(hist_id, 'alb_vis', 'Albedo visible', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+       CALL histdef(hist_id, 'alb_nir', 'Albedo near infrared', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+       ! Ajouts Nathalie - Septembre 2008
+       CALL histdef(hist_id, 'soilalb_vis', 'Soil Albedo visible', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+       CALL histdef(hist_id, 'soilalb_nir', 'Soil Albedo near infrared', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+       CALL histdef(hist_id, 'vegalb_vis', 'Vegetation Albedo visible', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+       CALL histdef(hist_id, 'vegalb_nir', 'Vegetation Albedo near infrared', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+       ! Fin ajouts Nathalie - Septembre 2008
+       CALL histdef(hist_id, 'z0', 'Surface roughness', 'm',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+       CALL histdef(hist_id, 'roughheight', 'Effective roughness height', 'm',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(2), dt,dw)
+       CALL histdef(hist_id, 'transpir', 'Transpiration', 'mm/d', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(2), dt,dw)
+       CALL histdef(hist_id, 'inter', 'Interception loss', 'mm/d', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(2), dt,dw)
+       !-
+       !- SECHIBA_HISTLEVEL = 3
+       !-
+       CALL histdef(hist_id, 'tsol_max', 'Maximum Surface Temperature',&
+            & 'C', iim,jjm, hori_id, 1,1,1, -99, 32, tmaxcels(3), dt,dw)
+       CALL histdef(hist_id, 'tsol_min', 'Minimum Surface Temperature',&
+            & 'C', iim,jjm, hori_id, 1,1,1, -99, 32, tmincels(3), dt,dw)
+       CALL histdef(hist_id, 'fluxsens', 'Sensible Heat Flux', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(3), dt,dw)
+       CALL histdef(hist_id, 'fluxlat', 'Latent Heat Flux', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(3), dt,dw)
+       CALL histdef(hist_id, 'snow', 'Snow mass', 'kg/m^2', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'snowage', 'Snow age', '?', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'snownobio', 'Snow on other surfaces', 'kg/m^2', &
+            & iim,jjm, hori_id, nnobio,1, nnobio, nobioax_id, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'snownobioage', 'Snow age on other surfaces', 'd', &
+            & iim,jjm, hori_id, nnobio,1, nnobio, nobioax_id, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'vegetfrac', 'Fraction of vegetation', '1', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'maxvegetfrac', 'Maximum fraction of vegetation', '1', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'nobiofrac', 'Fraction of other surface types', '1', &
+            & iim,jjm, hori_id, nnobio, 1, nnobio, nobioax_id, 32, avescatter(3), dt,dw)
+       IF ( control_flags%hydrol_cwrr ) THEN
+          DO jst=1,nstm
+             
+             ! var_name= "mc_1" ... "mc_3"
+             WRITE (var_name,"('moistc_',i1)") jst
+             CALL histdef(hist_id, var_name, 'Soil Moisture profile for soil type', '%', &
+                  & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(3),  dt,dw)
+             
+             ! var_name= "vegetsoil_1" ... "vegetsoil_3"
+             WRITE (var_name,"('vegetsoil_',i1)") jst
+             CALL histdef(hist_id, var_name, 'Fraction of vegetation on soil types', '%', &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3),  dt,dw)
+             
+          ENDDO
+       ENDIF
+       !-
+       !- SECHIBA_HISTLEVEL = 4
+       !-
+       IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+          CALL histdef(hist_id, 'dss', 'Up-reservoir Height', 'm',  &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(4), dt,dw)
+          CALL histdef(hist_id, 'gqsb', 'Upper Soil Moisture', '1',  &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+          CALL histdef(hist_id, 'bqsb', 'Lower Soil Moisture', '1',  &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+       ELSE
+          CALL histdef(hist_id, 'humtot', 'Total Soil Moisture', 'Kg/m2', &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(4), dt,dw)
+          CALL histdef(hist_id, 'humtot_soil', 'Soil Moisture for soil type', 'Kg/m2', &
+               & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, avescatter(4), dt,dw)
+       ENDIF
+       CALL histdef(hist_id, 'qsintveg', 'Water on canopy', 'Kg/m^2', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(4), dt,dw)
+       CALL histdef(hist_id, 'rstruct', 'Structural resistance', 's/m', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(4), dt,dw)
+       IF ( control_flags%ok_co2 ) THEN
+          CALL histdef(hist_id, 'gpp', 'Net assimilation of carbon by the vegetation', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(4), dt,dw)
+       ENDIF
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histdef(hist_id, 'nee', 'Net Ecosystem Exchange', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(4), dt,dw)
+          CALL histdef(hist_id, 'maint_resp', 'Maintenance respiration', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(4), dt,dw)
+          CALL histdef(hist_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(4), dt,dw)
+          CALL histdef(hist_id, 'growth_resp', 'Growth respiration', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(4), dt,dw)
+          CALL histdef(hist_id, 'npp', 'Net Primary Production', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt, dw)
+       ENDIF
+       CALL histdef(hist_id, 'precisol', 'Throughfall', 'mm/d',  &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop(4), dt,dw)
+       CALL histdef(hist_id, 'drysoil_frac', 'Fraction of visibly dry soil', '1',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(4), dt,dw)
+       CALL histdef(hist_id, 'evapot', 'Potential evaporation', 'mm/d',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
+       CALL histdef(hist_id, 'evapot_corr', 'Potential evaporation', 'mm/d',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(4), dt,dw)
+       !-
+       !- SECHIBA_HISTLEVEL = 5
+       !-
+       CALL histdef(hist_id, 'swnet', 'Net solar radiation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(5), dt,dw)
+       CALL histdef(hist_id, 'swdown', 'Incident solar radiation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(5), dt,dw)
+       CALL histdef(hist_id, 'lwdown', 'Absorbed downward longwave radiation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(5), dt,dw)
+       CALL histdef(hist_id, 'lwnet', 'Net surface longwave radiation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(5), dt,dw)
+       CALL histdef(hist_id, 'temp_pheno', 'Temperature for Pheno', 'K',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(5), dt,dw)
+       !-
+       !- SECHIBA_HISTLEVEL = 6
+       !-
+       CALL histdef(hist_id, 'ptn', 'Deep ground temperature', 'K', &
+            & iim,jjm, hori_id, ngrnd, 1, ngrnd, solax_id, 32, avescatter(6),  dt,dw)
+       !-
+       !- SECHIBA_HISTLEVEL = 7
+       !-
+       IF ( control_flags%river_routing ) THEN
+          CALL histdef(hist_id, 'fastr', 'Fast flow reservoir', 'kg/m^2', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(7), dt,dw)
+          CALL histdef(hist_id, 'slowr', 'Slow flow reservoir', 'kg/m^2', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(7), dt,dw)
+          CALL histdef(hist_id, 'streamr', 'Stream flow reservoir', 'kg/m^2', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(7), dt,dw)
+          CALL histdef(hist_id, 'lakevol', 'Volume in lake reservoir', 'kg/m^2', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(7), dt,dw)
+          CALL histdef(hist_id, 'irrigation', 'Net irrigation', 'mm/d', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(7), dt,dw)
+          CALL histdef(hist_id, 'netirrig', 'Net irrigation requirement', 'mm/d', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop(7), dt,dw)
+          CALL histdef(hist_id, 'irrigmap', 'Map of irrigated areas', 'm^2', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, once(7), dt,dw)
+       ENDIF
+       !-
+       !- SECHIBA_HISTLEVEL = 8
+       !-
+       CALL histdef(hist_id, 'beta', 'Beta Function', '1',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+       CALL histdef(hist_id, 'raero', 'Aerodynamic resistance', 's/m',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+       ! Ajouts Nathalie - Novembre 2006
+       CALL histdef(hist_id, 'cdrag', 'Drag coefficient for LE and SH', '?',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+       CALL histdef(hist_id, 'Wind', 'Wind speed', 'm/s',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+       ! Fin ajouts Nathalie
+!MM
+       CALL histdef(hist_id, 'qsatt' , 'Surface saturated humidity', 'g/g', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+       CALL histdef(hist_id, 'vbeta1', 'Beta for sublimation', '1',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+       CALL histdef(hist_id, 'vbeta4', 'Beta for bare soil', '1',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(8), dt,dw)
+       CALL histdef(hist_id, 'vbetaco2', 'beta for CO2', 'mm/d', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(8), dt,dw)
+       CALL histdef(hist_id, 'soiltype', 'Fraction of soil textures', '%', &
+            & iim,jjm, hori_id, nstm, 1, nstm, soltax_id, 32, once(8),  dt,dw)
+       CALL histdef(hist_id, 'humrel', 'Soil moisture stress', '1',  &
+            & iim,jjm, hori_id, nvm,1,nvm, vegax_id, 32, avescatter(8), dt,dw)
+       !-
+       !- SECHIBA_HISTLEVEL = 9
+       !-
+       !-
+       !- SECHIBA_HISTLEVEL = 10
+       !-
+       CALL histdef(hist_id, 'cimean', 'Stomatal CO2 concentation', 'mmole/m2/s', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
+       CALL histdef(hist_id, 'vbeta3', 'Beta for Transpiration', 'mm/d', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
+       CALL histdef(hist_id, 'rveget', 'Canopy resistance', 's/m', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
+       CALL histdef(hist_id, 'rsol', 'Soil resistance', 's/m',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(10), dt,dw)
+       CALL histdef(hist_id,'vbeta2','Beta for Interception loss','mm/d', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
+       CALL histdef(hist_id, 'qsintmax', 'Maximum Interception capacity', 'Kg/m^2', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(10), dt,dw)
+
+       !- SECHIBA_HISTLEVEL = 11
+       !-
+
+       IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+          CALL histdef(hist_id, 'mrsos', "Moisture in Upper 0.1 m of Soil Column", "kg m-2", &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+          CALL histdef(hist_id, 'mrso', "Total Soil Moisture Content", "kg m-2", &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+          CALL histdef(hist_id, 'mrros', "Surface Runoff", "kg m-2 s-1", &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+          CALL histdef(hist_id, 'mrro', "Total Runoff", "kg m-2 s-1", &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+          CALL histdef(hist_id, 'prveg', "Precipitation onto Canopy", "kg m-2 s-1", &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       ENDIF
+
+
+       CALL histdef(hist_id, 'evspsblveg', "Evaporation from Canopy", "kg m-2 s-1", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       CALL histdef(hist_id, 'evspsblsoi', "Water Evaporation from Soil", "kg m-2 s-1", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       CALL histdef(hist_id, 'tran', "Transpiration", "kg m-2 s-1", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       CALL histdef(hist_id, 'treeFrac', "Tree Cover Fraction", "%", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       CALL histdef(hist_id, 'grassFrac', "Natural Grass Fraction", "%", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       CALL histdef(hist_id, 'cropFrac', "Crop Fraction", "%", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       CALL histdef(hist_id, 'baresoilFrac', "Bare Soil Fraction", "%", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+       CALL histdef(hist_id, 'residualFrac', &
+            & "Fraction of Grid Cell that is Land but Neither Vegetation-Covered nor Bare Soil", "%", &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(11), dt,dw)
+
+    ELSE 
+       !-
+       !- This is the ALMA convention output now
+       !-
+       !- 
+       IF ( rectilinear ) THEN
+#ifdef CPP_PARA
+          CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id,orch_domain_id)
+#else
+          CALL histbeg(histname, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id)
+#endif
+       ELSE
+#ifdef CPP_PARA
+          CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id,domain_id=orch_domain_id)
+#else
+          CALL histbeg(histname, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id)
+#endif
+       ENDIF
+       !-
+       CALL histvert(hist_id, 'veget', 'Vegetation types', '1', &
+            &    nvm,   veg, vegax_id)
+       CALL histvert(hist_id, 'solth', 'Soil levels',      'm', &
+            &    ngrnd, sol, solax_id)
+       CALL histvert(hist_id, 'soiltyp', 'Soil types',      '1', &
+            &    nstm, soltyp, soltax_id)
+       CALL histvert(hist_id, 'nobio', 'Other surface types',      '1', &
+            &    nnobio, nobiotyp, nobioax_id)
+       IF (  control_flags%hydrol_cwrr ) THEN
+          CALL histvert(hist_id, 'solay', 'Hydrol soil levels',      'm', &
+               &    nslm, solay, solayax_id)
+       ENDIF
+     !-
+     !-  Vegetation
+     !-
+       CALL histdef(hist_id, 'vegetfrac', 'Fraction of vegetation', '1', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'maxvegetfrac', 'Maximum fraction of vegetation', '1', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter(3), dt,dw)
+       CALL histdef(hist_id, 'nobiofrac', 'Fraction of other surface types', '1', &
+            & iim,jjm, hori_id, nnobio, 1, nnobio, nobioax_id, 32, avescatter(3), dt,dw)
+     !- 
+     !-  General energy balance
+     !-
+       CALL histdef(hist_id, 'SWnet', 'Net shortwave radiation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+       CALL histdef(hist_id, 'LWnet', 'Net longwave radiation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'Qh', 'Sensible heat flux', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+       CALL histdef(hist_id, 'Qle', 'Latent heat flux', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+       CALL histdef(hist_id, 'Qg', 'Ground heat flux', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'Qf', 'Energy of fusion', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(2), dt,dw)
+       CALL histdef(hist_id, 'Qv', 'Energy of sublimation', 'W/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'DelSurfHeat', 'Change in surface layer heat', 'J/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, sumscatter(1), dt,dw)
+       CALL histdef(hist_id, 'DelColdCont', 'Change in snow surface layer cold content', 'J/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, sumscatter(1), dt,dw)
+    !-
+    !- General water balance
+    !-
+       CALL histdef(hist_id, 'Snowf', 'Snowfall rate', 'kg/m^2/s',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'Rainf', 'Rainfall rate', 'kg/m^2/s',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'Evap', 'Total Evapotranspiration', 'kg/m^2/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'Qs', 'Surface runoff', 'kg/m^2/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'Qsb', 'Sub-surface runoff', 'kg/m^2/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'Qsm', 'Snowmelt', 'kg/m^2/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'DelSoilMoist', 'Change in soil moisture', 'kg/m^2',  &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(1), dt,dw)
+       CALL histdef(hist_id, 'DelSWE', 'Change in SWE','kg/m^2',&
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(1), dt,dw)
+       CALL histdef(hist_id, 'DelIntercept', 'Change in interception storage', 'kg/m^2',  &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, sumscatter(1), dt,dw)
+    !-
+    !- Surface state
+    !-
+       CALL histdef(hist_id, 'AvgSurfT', 'Average surface temperature', 'K', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+       CALL histdef(hist_id, 'RadT', 'Surface radiative temperature', 'K', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, ave(1), dt,dw)
+       CALL histdef(hist_id, 'Albedo', 'Albedo', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'SWE', '3D soil water equivalent','kg/m^2',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+    !!-
+    !-  Sub-surface state
+    !- 
+       IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+          CALL histdef(hist_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2',  &
+               & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(1), dt,dw)
+       ELSE
+          CALL histdef(hist_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2',  &
+               & iim,jjm, hori_id, nslm, 1, nslm, solayax_id, 32, avescatter(1), dt,dw)
+       ENDIF
+       CALL histdef(hist_id, 'SoilWet', 'Total soil wetness', 'kg/m^2',  &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'SoilTemp', '3D layer average soil temperature', 'K', &
+            & iim,jjm, hori_id, ngrnd, 1, ngrnd, solax_id, 32, avescatter(1),  dt,dw)
+    !- 
+    !-  Evaporation components
+    !-
+       CALL histdef(hist_id, 'PotEvap', 'Potential evapotranspiration', 'kg/m^2/s', &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'ECanop', 'Interception evaporation', 'kg/m^2/s', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'TVeg', 'Transpiration', 'kg/m^2/s', &
+            & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'ESoil', 'Bare soil evaporation', 'kg/m^2/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'RootMoist','Root zone soil water', 'kg/m^2',  &
+            & iim,jjm, hori_id, 1, 1, 1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'SubSnow','Snow sublimation','kg/m^2/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(1), dt,dw)
+       CALL histdef(hist_id, 'ACond', 'Aerodynamic conductance', 'm/s',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+    !-
+    !-
+    !-  Cold Season Processes
+    !-
+       CALL histdef(hist_id, 'SnowFrac', 'Snow cover fraction', '1',  &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'SAlbedo', 'Snow albedo', '1', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+       CALL histdef(hist_id, 'SnowDepth', '3D snow depth', 'm', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, avescatter(1), dt,dw)
+    !-
+    !- Hydrologic variables
+    !-
+       CALL histdef(hist_id, 'IrrigationMap', 'Map of irrigated areas', 'm^2', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, once(7), dt,dw)
+       CALL histdef(hist_id, 'dis', 'Simulated River Discharge', 'm^3/s', &
+            & iim,jjm, hori_id, 1,1,1, -99, 32, fluxop_scinsec(2), dt,dw)
+       CALL histdef(hist_id, 'humrel', 'Soil moisture stress', '1',  &
+            & iim,jjm, hori_id, nvm,1,nvm, vegax_id, 32, avescatter(8), dt,dw)
+    !-
+    !-  The carbon budget
+    !-
+       IF ( control_flags%ok_co2 ) THEN
+          CALL histdef(hist_id, 'GPP', 'Net assimilation of carbon by the vegetation', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+       ENDIF
+       IF ( control_flags%ok_stomate ) THEN
+          CALL histdef(hist_id, 'NEE', 'Net Ecosystem Exchange', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+          CALL histdef(hist_id, 'maint_resp', 'Maintenance respiration', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+          CALL histdef(hist_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+          CALL histdef(hist_id, 'growth_resp', 'Growth respiration', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+          CALL histdef(hist_id, 'npp', 'Net Primary Production', 'gC/m^2/s', &
+               & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, fluxop_scinsec(1), dt,dw)
+       ENDIF
+    !
+    ENDIF
+    !-
+    CALL histdef(hist_id, 'LandPoints', 'Land Points', '1', &
+               & iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt,dw)  
+    CALL histdef(hist_id, 'Areas', 'Mesh areas', 'm2', &
+         & iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt, dw)
+    CALL histdef(hist_id, 'Contfrac', 'Continental fraction', '1', &
+         & iim,jjm, hori_id, 1,1,1, -99, 32, once(1), dt, dw)
+    !-
+    CALL histend(hist_id)
+    !
+    !
+    ! Second SECHIBA hist file
+    !
+    !-
+    !Config  Key  = SECHIBA_HISTFILE2
+    !Config  Desc = Flag to switch on histfile 2 for SECHIBA (hi-frequency ?)
+    !Config  Def  = FALSE
+    !Config  Help = This Flag switch on the second SECHIBA writing for hi (or low) 
+    !Config         frequency writing. This second output is optional and not written
+    !Config         by default.
+    !Config MM is it right ? Second output file is produced with the same level 
+    !Config         as the first one.
+    !-
+    ok_histfile2=.FALSE.
+    CALL getin_p('SECHIBA_HISTFILE2', ok_histfile2)
+    WRITE(numout,*) 'SECHIBA_HISTFILE2 ', ok_histfile2
+    !
+    hist2_id = -1
+    !
+    IF (ok_histfile2) THEN
+       !-
+       !Config  Key  = SECHIBA_OUTPUT_FILE2
+       !Config  Desc = Name of file in which the output number 2 is going
+       !Config         to be written
+       !Config  If   = SECHIBA_HISTFILE2
+       !Config  Def  = sechiba_out_2.nc
+       !Config  Help = This file is going to be created by the model
+       !Config         and will contain the output 2 from the model.
+       !-
+       histname2='sechiba_out_2.nc'
+       CALL getin_p('SECHIBA_OUTPUT_FILE2', histname2)
+       WRITE(numout,*) 'SECHIBA_OUTPUT_FILE2 ', histname2
+       !-
+       !Config  Key  = WRITE_STEP2
+       !Config  Desc = Frequency in seconds at which to WRITE output
+       !Config  If   = SECHIBA_HISTFILE2
+       !Config  Def  = 1800.0
+       !Config  Help = This variables gives the frequency the output 2 of
+       !Config         the model should be written into the netCDF file.
+       !Config         It does not affect the frequency at which the
+       !Config         operations such as averaging are done.
+       !Config         That is IF the coding of the calls to histdef
+       !Config         are correct !
+       !-
+       dw2 = 1800.0
+       CALL getin_p('WRITE_STEP2', dw2)
+       !-
+       !Config  Key  = SECHIBA_HISTLEVEL2
+       !Config  Desc = SECHIBA history 2 output level (0..10)
+       !Config  If   = SECHIBA_HISTFILE2
+       !Config  Def  = 1
+       !Config  Help = Chooses the list of variables in the history file. 
+       !Config         Values between 0: nothing is written; 10: everything is 
+       !Config         written are available More details can be found on the web under documentation.
+       !Config         web under documentation.
+       !Config         First level contains all ORCHIDEE outputs.
+       !-
+       hist2_level = 1
+       CALL getin_p('SECHIBA_HISTLEVEL2', hist2_level)
+       !-
+       WRITE(numout,*) 'SECHIBA history level 2 : ',hist2_level
+       IF ( (hist2_level > max_hist_level).OR.(hist2_level < 0) ) THEN
+          STOP 'This history level 2 is not allowed'
+       ENDIF
+       !
+       !-
+       !- define operations as a function of history level.
+       !- Above hist2_level, operation='never'
+       !-
+       ave2(1:max_hist_level) = 'ave(X)'
+       IF (hist2_level < max_hist_level) THEN
+          ave2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+       sumscatter2(1:max_hist_level) = 't_sum(scatter(X))'
+       IF (hist2_level < max_hist_level) THEN
+          sumscatter2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+       avecels2(1:max_hist_level) = 'ave(cels(X))'
+       IF (hist2_level < max_hist_level) THEN
+          avecels2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+       avescatter2(1:max_hist_level) = 'ave(scatter(X))'
+       IF (hist2_level < max_hist_level) THEN
+          avescatter2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+       tmincels2(1:max_hist_level) = 't_min(cels(X))'
+       IF (hist2_level < max_hist_level) THEN
+          tmincels2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+       tmaxcels2(1:max_hist_level) = 't_max(cels(X))'
+       IF (hist2_level < max_hist_level) THEN
+          tmaxcels2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+!!$       tmax2(1:max_hist_level) = 't_max(X)'
+!!$       IF (hist2_level < max_hist_level) THEN
+!!$          tmax2(hist2_level+1:max_hist_level) = 'never'
+!!$       ENDIF
+       fluxop2(1:max_hist_level) = flux_op
+       IF (hist2_level < max_hist_level) THEN
+          fluxop2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+!!$       fluxop_sc2(1:max_hist_level) = flux_sc
+!!$       IF (hist2_level < max_hist_level) THEN
+!!$          fluxop_sc2(hist2_level+1:max_hist_level) = 'never'
+!!$       ENDIF
+!!$       fluxop_insec2(1:max_hist_level) = flux_insec
+!!$       IF (hist2_level < max_hist_level) THEN
+!!$          fluxop_insec2(hist2_level+1:max_hist_level) = 'never'
+!!$       ENDIF
+       fluxop_scinsec2(1:max_hist_level) = flux_scinsec
+       IF (hist2_level < max_hist_level) THEN
+          fluxop_scinsec2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+       once2(1:max_hist_level) = 'once(scatter(X))'
+       IF (hist2_level < max_hist_level) THEN
+          once2(hist2_level+1:max_hist_level) = 'never'
+       ENDIF
+       ! 
+       IF ( .NOT. almaoutput ) THEN
+          !- 
+          IF ( rectilinear ) THEN
+#ifdef CPP_PARA
+             CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id,orch_domain_id)
+#else
+             CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id)
+#endif
+             WRITE(numout,*)  'HISTBEG2 --->',istp_old,date0,dt,dw2,hist2_id
+          ELSE
+#ifdef CPP_PARA
+             CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id,domain_id=orch_domain_id)
+#else
+             CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id)
+#endif
+          ENDIF
+          !-
+          CALL histvert(hist2_id, 'veget', 'Vegetation types', '1', &
+               &    nvm,   veg, vegax_id2)
+          CALL histvert(hist2_id, 'solth', 'Soil levels',      'm', &
+               &    ngrnd, sol, solax_id2)
+          CALL histvert(hist2_id, 'soiltyp', 'Soil types',      '1', &
+               &    nstm, soltyp, soltax_id2)
+          CALL histvert(hist2_id, 'nobio', 'Other surface types',      '1', &
+               &    nnobio, nobiotyp, nobioax_id2)
+          CALL histvert(hist2_id, 'albtyp', 'Albedo Types',     '1', &
+               &    2, albtyp, albax_id2)
+          IF (  control_flags%hydrol_cwrr ) THEN
+             CALL histvert(hist2_id, 'solay', 'Hydrol soil levels',      'm', &
+                  &    nslm, solay, solayax_id2)
+          ENDIF
+          !-
+          !- SECHIBA_HISTLEVEL2 = 1
+          !-
+          CALL histdef(hist2_id, 'ptn', 'Deep ground temperature', 'K', &
+               & iim,jjm, hori_id2, ngrnd, 1, ngrnd, solax_id2, 32, avescatter2(1),  dt, dw2)
+          IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+             CALL histdef(hist2_id, 'mrsos', "Moisture in Upper 0.1 m of Soil Column", "kg m-2", &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+
+             CALL histdef(hist2_id, 'mrro', "Total Runoff", "kg m-2 s-1", &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt,dw2)
+          ENDIF
+          !-
+          !- SECHIBA_HISTLEVEL2 = 2
+          !-
+          CALL histdef(hist2_id, 'cdrag', 'Drag coefficient for LE and SH', '?',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt, dw2)
+          ! Ajouts Nathalie - Septembre 2008
+          CALL histdef(hist2_id, 'soilalb_vis', 'Soil Albedo visible', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt,dw2)
+          CALL histdef(hist2_id, 'soilalb_nir', 'Soil Albedo near infrared', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt,dw2)
+          CALL histdef(hist2_id, 'vegalb_vis', 'Vegetation Albedo visible', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt,dw2)
+          CALL histdef(hist2_id, 'vegalb_nir', 'Vegetation Albedo near infrared', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt,dw2)
+          ! Fin ajouts Nathalie - Septembre 2008
+          CALL histdef(hist2_id, 'z0', 'Surface roughness', 'm',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(2), dt, dw2)
+          CALL histdef(hist2_id, 'coastalflow', 'Diffuse coastal flow', 'm^3/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(2), dt, dw2)
+          CALL histdef(hist2_id, 'riverflow', 'River flow to the oceans', 'm^3/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(2), dt, dw2) 
+          CALL histdef(hist2_id, 'tsol_rad', 'Radiative surface temperature', 'C', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avecels2(2), dt, dw2)
+          CALL histdef(hist2_id, 'vevapnu', 'Bare soil evaporation', 'mm/d', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(2), dt, dw2)
+          CALL histdef(hist2_id, 'temp_sol', 'New Surface Temperature', 'C', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avecels2(2), dt, dw2)
+          CALL histdef(hist2_id, 'qsurf', 'Near surface specific humidity', 'g/g',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(2), dt, dw2)
+          CALL histdef(hist2_id, 'albedo', 'Albedo', '1', &
+               & iim,jjm, hori_id2, 2,1,2, albax_id2, 32, avescatter2(2), dt, dw2)
+          CALL histdef(hist2_id, 'fluxsens', 'Sensible Heat Flux', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(2), dt, dw2)
+          CALL histdef(hist2_id, 'fluxlat', 'Latent Heat Flux', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(2), dt, dw2)
+          CALL histdef(hist2_id, 'emis', 'Surface emissivity', '?', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(2), dt, dw2)
+          !-
+          !- SECHIBA_HISTLEVEL2 = 3
+          !-
+          CALL histdef(hist2_id, 'evap', 'Evaporation', 'mm/d', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(3), dt, dw2)
+          CALL histdef(hist2_id, 'rain', 'Rainfall', 'mm/d',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(3), dt, dw2)
+          CALL histdef(hist2_id, 'snowf', 'Snowfall', 'mm/d',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(3), dt, dw2)
+          CALL histdef(hist2_id, 'netrad', 'Net radiation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(3), dt, dw2)
+          CALL histdef(hist2_id, 'lai', 'Leaf Area Index', '1', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(3), dt, dw2)
+          IF ( control_flags%river_routing ) THEN
+             CALL histdef(hist2_id, 'basinmap', 'Aproximate map of the river basins', ' ', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(3), dt, dw2) 
+             CALL histdef(hist2_id, 'nbrivers', 'Number or rivers in the outflow grid box', ' ', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(3), dt, dw2)  
+          ENDIF
+          !-
+          !- SECHIBA_HISTLEVEL2 = 4
+          !-
+          CALL histdef(hist2_id, 'subli', 'Sublimation', 'mm/d', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+          CALL histdef(hist2_id, 'runoff', 'Surface runoff', 'mm/d', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+          CALL histdef(hist2_id, 'drainage', 'Deep drainage', 'mm/d', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+          IF ( control_flags%river_routing ) THEN
+             CALL histdef(hist2_id, 'riversret', 'Return from endorheic rivers', 'mm/d', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(4), dt, dw2)
+             CALL histdef(hist2_id, 'hydrographs', 'Hydrographs of gridbox outflow', 'm^3/s', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(4), dt, dw2)
+          ENDIF
+          IF ( control_flags%hydrol_cwrr ) THEN
+             CALL histdef(hist2_id, 'evapnu_soil', 'Bare soil evap for soil type', 'mm/d', &
+                  & iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(4), dt, dw2)
+             CALL histdef(hist2_id, 'drainage_soil', 'Drainage for soil type', 'mm/d', &
+                  & iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(4), dt, dw2)
+             CALL histdef(hist2_id, 'transpir_soil', 'Transpir for soil type', 'mm/d', &
+                  & iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(4), dt, dw2)
+             CALL histdef(hist2_id, 'runoff_soil', 'Runoff for soil type', 'mm/d', &
+                  & iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, fluxop2(4), dt, dw2)
+          ENDIF
+          !
+          CALL histdef(hist2_id, 'tair', 'Air Temperature', 'K',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+          CALL histdef(hist2_id, 'qair', 'Air humidity', 'g/g',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+          ! Ajouts Nathalie - Juillet 2006
+          CALL histdef(hist2_id, 'q2m', '2m Air humidity', 'g/g',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+          CALL histdef(hist2_id, 't2m', '2m Air Temperature', 'K',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+          ! Fin ajouts Nathalie
+          CALL histdef(hist2_id, 'alb_vis', 'Albedo visible', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+          CALL histdef(hist2_id, 'alb_nir', 'Albedo near infrared', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(4), dt, dw2)
+          CALL histdef(hist2_id, 'roughheight', 'Effective roughness height', 'm',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(4), dt, dw2)
+          CALL histdef(hist2_id, 'transpir', 'Transpiration', 'mm/d', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(4), dt, dw2)
+          CALL histdef(hist2_id, 'inter', 'Interception loss', 'mm/d', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(4), dt, dw2)
+          !-
+          !- SECHIBA_HISTLEVEL2 = 5
+          !-
+          CALL histdef(hist2_id, 'tsol_max', 'Maximum Surface Temperature',&
+               & 'C', iim,jjm, hori_id2, 1,1,1, -99, 32, tmaxcels2(5), dt, dw2)
+          CALL histdef(hist2_id, 'tsol_min', 'Minimum Surface Temperature',&
+               & 'C', iim,jjm, hori_id2, 1,1,1, -99, 32, tmincels2(5), dt, dw2)
+          CALL histdef(hist2_id, 'snow', 'Snow mass', 'kg/m^2', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(5), dt, dw2)
+          CALL histdef(hist2_id, 'snowage', 'Snow age', '?', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(5), dt, dw2)
+          CALL histdef(hist2_id, 'snownobio', 'Snow on other surfaces', 'kg/m^2', &
+               & iim,jjm, hori_id2, nnobio,1, nnobio, nobioax_id2, 32, avescatter2(5), dt, dw2)
+          CALL histdef(hist2_id, 'snownobioage', 'Snow age on other surfaces', 'd', &
+               & iim,jjm, hori_id2, nnobio,1, nnobio, nobioax_id2, 32, avescatter2(5), dt, dw2)
+          CALL histdef(hist2_id, 'vegetfrac', 'Fraction of vegetation', '1', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(5), dt, dw2)
+          CALL histdef(hist2_id, 'maxvegetfrac', 'Maximum fraction of vegetation', '1', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(5), dt, dw2)
+          CALL histdef(hist2_id, 'nobiofrac', 'Fraction of other surface types', '1', &
+               & iim,jjm, hori_id2, nnobio, 1, nnobio, nobioax_id2, 32, avescatter2(5), dt, dw2)
+          IF ( control_flags%hydrol_cwrr ) THEN
+             DO jst=1,nstm
+
+                ! var_name= "mc_1" ... "mc_3"
+                WRITE (var_name,"('moistc_',i1)") jst
+                CALL histdef(hist2_id, var_name, 'Soil Moisture profile for soil type', '%', &
+                     & iim,jjm, hori_id2, nslm, 1, nslm, solayax_id2, 32, avescatter2(5), dt, dw2)
+
+                ! var_name= "vegetsoil_1" ... "vegetsoil_3"
+                WRITE (var_name,"('vegetsoil_',i1)") jst
+                CALL histdef(hist2_id, var_name, 'Fraction of vegetation on soil types', '%', &
+                     & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(5), dt, dw2)
+
+             ENDDO
+          ENDIF
+          !-
+          !- SECHIBA_HISTLEVEL2 = 6
+          !-
+          IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+             CALL histdef(hist2_id, 'dss', 'Up-reservoir Height', 'm',  &
+                  & iim,jjm, hori_id, nvm, 1, nvm, vegax_id, 32, avescatter2(6), dt,dw)
+             CALL histdef(hist2_id, 'gqsb', 'Upper Soil Moisture', '1',  &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(6), dt, dw2)
+             CALL histdef(hist2_id, 'bqsb', 'Lower Soil Moisture', '1',  &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(6), dt, dw2)
+          ELSE
+             CALL histdef(hist2_id, 'humtot', 'Total Soil Moisture', 'Kg/m2', &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(6), dt, dw2)
+             CALL histdef(hist2_id, 'humtot_soil', 'Soil Moisture for soil type', 'Kg/m2', &
+                  & iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, avescatter2(6), dt, dw2)
+          ENDIF
+          CALL histdef(hist2_id, 'qsintveg', 'Water on canopy', 'Kg/m^2', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(6), dt, dw2)
+          CALL histdef(hist2_id, 'rstruct', 'Structural resistance', 's/m', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(6), dt, dw2)
+          IF ( control_flags%ok_co2 ) THEN
+             CALL histdef(hist2_id, 'gpp', 'Net assimilation of carbon by the vegetation', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(6), dt,dw2)
+          ENDIF
+          IF ( control_flags%ok_stomate ) THEN
+             CALL histdef(hist2_id, 'nee', 'Net Ecosystem Exchange', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(2), dt,dw2)
+             CALL histdef(hist2_id, 'maint_resp', 'Maintenance respiration', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(2), dt,dw2)
+             CALL histdef(hist2_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(2), dt,dw2)
+             CALL histdef(hist2_id, 'growth_resp', 'Growth respiration', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(2), dt, dw2)
+             CALL histdef(hist2_id, 'npp', 'Net Primary Production', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(2), dt, dw2)
+          ENDIF
+          CALL histdef(hist2_id, 'precisol', 'Throughfall', 'mm/d',  &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop2(6), dt, dw2)
+          CALL histdef(hist2_id, 'drysoil_frac', 'Fraction of visibly dry soil', '1',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(6), dt, dw2)
+          CALL histdef(hist2_id, 'evapot', 'Potential evaporation', 'mm/d',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(6), dt, dw2)
+          CALL histdef(hist2_id, 'evapot_corr', 'Potential evaporation', 'mm/d',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(6), dt, dw2)
+          !-
+          !- SECHIBA_HISTLEVEL2 = 7
+          !-
+          CALL histdef(hist2_id, 'swnet', 'Net solar radiation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(7), dt, dw2)
+          CALL histdef(hist2_id, 'swdown', 'Incident solar radiation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(7), dt, dw2)
+          CALL histdef(hist2_id, 'lwdown', 'Absorbed downward longwave radiation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(7), dt, dw2)
+          CALL histdef(hist2_id, 'lwnet', 'Net surface longwave radiation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(7), dt, dw2)
+          CALL histdef(hist2_id, 'temp_pheno', 'Temperature for Pheno', 'K',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(7), dt, dw2)
+          !-
+          !- SECHIBA_HISTLEVEL2 = 8
+          !-
+          IF ( control_flags%river_routing ) THEN
+             CALL histdef(hist2_id, 'fastr', 'Fast flow reservoir', 'kg/m^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt, dw2)
+             CALL histdef(hist2_id, 'slowr', 'Slow flow reservoir', 'kg/m^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt, dw2)
+             CALL histdef(hist2_id, 'streamr', 'Stream flow reservoir', 'kg/m^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt, dw2)
+             CALL histdef(hist2_id, 'lakevol', 'Volume in lake reservoir', 'kg/m^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(8), dt, dw2)
+             CALL histdef(hist2_id, 'irrigation', 'Net irrigation', 'mm/d', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(8), dt, dw2)
+             CALL histdef(hist2_id, 'netirrig', 'Net irrigation requirement', 'mm/d', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop2(8), dt, dw2)
+             CALL histdef(hist2_id, 'irrigmap', 'Map of irrigated areas', 'm^2', &
+                  & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(8), dt, dw2)
+          ENDIF
+          !-
+          !- SECHIBA_HISTLEVEL2 = 9
+          !-
+          CALL histdef(hist2_id, 'beta', 'Beta Function', '1',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
+          CALL histdef(hist2_id, 'raero', 'Aerodynamic resistance', 's/m',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
+          ! Ajouts Nathalie - Novembre 2006
+          CALL histdef(hist2_id, 'Wind', 'Wind speed', 'm/s',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
+          ! Fin ajouts Nathalie
+          CALL histdef(hist2_id, 'qsatt' , 'Surface saturated humidity', 'g/g', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
+          CALL histdef(hist2_id, 'vbeta1', 'Beta for sublimation', '1',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
+          CALL histdef(hist2_id, 'vbeta4', 'Beta for bare soil', '1',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(9), dt, dw2)
+          CALL histdef(hist2_id, 'vbetaco2', 'beta for CO2', 'mm/d', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(9), dt, dw2)
+          CALL histdef(hist2_id, 'soiltype', 'Fraction of soil textures', '%', &
+               & iim,jjm, hori_id2, nstm, 1, nstm, soltax_id2, 32, once2(9),  dt, dw2)
+          CALL histdef(hist2_id, 'humrel', 'Soil moisture stress', '1',  &
+               & iim,jjm, hori_id2, nvm,1,nvm, vegax_id2, 32, avescatter2(9), dt, dw2)
+          !-
+          !- SECHIBA_HISTLEVEL2 = 10
+          !-
+          CALL histdef(hist2_id, 'cimean', 'Stomatal CO2 concentation', 'mmole/m2/s', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
+          CALL histdef(hist2_id, 'vbeta3', 'Beta for Transpiration', 'mm/d', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
+          CALL histdef(hist2_id, 'rveget', 'Canopy resistance', 's/m', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
+          CALL histdef(hist2_id, 'rsol', 'Soil resistance', 's/m',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(10), dt, dw2)
+          CALL histdef(hist2_id,'vbeta2','Beta for Interception loss','mm/d', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
+          CALL histdef(hist2_id, 'qsintmax', 'Maximum Interception capacity', 'Kg/m^2', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(10), dt, dw2)
+          ! 
+       ELSE 
+          !-
+          !- This is the ALMA convention output now
+          !-
+          !- 
+          IF ( rectilinear ) THEN
+#ifdef CPP_PARA
+             CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id,orch_domain_id)
+#else
+             CALL histbeg(histname2, iim, lon_rect, jjm, lat_rect, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id)
+#endif
+             WRITE(numout,*)  'HISTBEG2 --->',istp_old,date0,dt,dw2,hist2_id
+          ELSE
+#ifdef CPP_PARA
+             CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id,domain_id=orch_domain_id)
+#else
+             CALL histbeg(histname2, iim, lon, jjm, lat, 1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id2, hist2_id)
+#endif 
+          ENDIF
+          !-
+          CALL histvert(hist2_id, 'veget', 'Vegetation types', '1', &
+               &    nvm,   veg, vegax_id2)
+          CALL histvert(hist2_id, 'solth', 'Soil levels',      'm', &
+               &    ngrnd, sol, solax_id2)
+          CALL histvert(hist2_id, 'soiltyp', 'Soil types',      '1', &
+               &    nstm, soltyp, soltax_id2)
+          CALL histvert(hist2_id, 'nobio', 'Other surface types',      '1', &
+               &    nnobio, nobiotyp, nobioax_id2)
+          IF (  control_flags%hydrol_cwrr ) THEN
+             CALL histvert(hist2_id, 'solay', 'Hydrol soil levels',      'm', &
+                  &    nslm, solay, solayax_id2)
+          ENDIF
+          !-
+          !-  Vegetation
+          !-
+          CALL histdef(hist2_id, 'vegetfrac', 'Fraction of vegetation', '1', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(3), dt, dw2)
+          CALL histdef(hist2_id, 'maxvegetfrac', 'Maximum fraction of vegetation', '1', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, avescatter2(3), dt, dw2)
+          CALL histdef(hist2_id, 'nobiofrac', 'Fraction of other surface types', '1', &
+               & iim,jjm, hori_id2, nnobio, 1, nnobio, nobioax_id2, 32, avescatter2(3), dt, dw2)
+          !- 
+          !-  General energy balance
+          !-
+          CALL histdef(hist2_id, 'SWnet', 'Net shortwave radiation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
+          CALL histdef(hist2_id, 'LWnet', 'Net longwave radiation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Qh', 'Sensible heat flux', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Qle', 'Latent heat flux', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Qg', 'Ground heat flux', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Qf', 'Energy of fusion', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(2), dt, dw2)
+          CALL histdef(hist2_id, 'Qv', 'Energy of sublimation', 'W/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'DelSurfHeat', 'Change in surface layer heat', 'J/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, sumscatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'DelColdCont', 'Change in snow surface layer cold content', 'J/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, sumscatter2(1), dt, dw2)
+          !-
+          !- General water balance
+          !-
+          CALL histdef(hist2_id, 'Snowf', 'Snowfall rate', 'kg/m^2/s',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Rainf', 'Rainfall rate', 'kg/m^2/s',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Evap', 'Total Evapotranspiration', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Qs', 'Surface runoff', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Qsb', 'Sub-surface runoff', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Qsm', 'Snowmelt', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'DelSoilMoist', 'Change in soil moisture', 'kg/m^2',  &
+               & iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'DelSWE', 'Change in SWE','kg/m^2',&
+               & iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'DelIntercept', 'Change in interception storage', 'kg/m^2',  &
+               & iim,jjm, hori_id2, 1, 1, 1, -99, 32, sumscatter2(1), dt, dw2)
+          !-
+          !- Surface state
+          !-
+          CALL histdef(hist2_id, 'AvgSurfT', 'Average surface temperature', 'K', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
+          CALL histdef(hist2_id, 'RadT', 'Surface radiative temperature', 'K', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, ave2(1), dt, dw2)
+          CALL histdef(hist2_id, 'Albedo', 'Albedo', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'SWE', '3D soil water equivalent','kg/m^2',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          !!-
+          !-  Sub-surface state
+          !- 
+          IF ( .NOT. control_flags%hydrol_cwrr ) THEN
+             CALL histdef(hist2_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2',  &
+                  & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
+          ELSE
+             CALL histdef(hist2_id, 'SoilMoist', '3D average layer soil moisture', 'kg/m^2',  &
+                  & iim,jjm, hori_id2, nslm, 1, nslm, solayax_id2, 32, avescatter2(1), dt, dw2)
+          ENDIF
+          CALL histdef(hist2_id, 'SoilWet', 'Total soil wetness', 'kg/m^2',  &
+               & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'SoilTemp', '3D layer average soil temperature', 'K', &
+               & iim,jjm, hori_id2, ngrnd, 1, ngrnd, solax_id2, 32, avescatter2(1), dt, dw2)
+          !- 
+          !-  Evaporation components
+          !-
+          CALL histdef(hist2_id, 'PotEvap', 'Potential evapotranspiration', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, 1, 1, 1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'ECanop', 'Interception evaporation', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'TVeg', 'Transpiration', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'ESoil', 'Bare soil evaporation', 'kg/m^2/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'RootMoist','Root zone soil water', 'kg/m^2',  &
+               & iim,jjm, hori_id2, 1, 1, 1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'SubSnow','Snow sublimation','kg/m^2/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(1), dt, dw2)
+          CALL histdef(hist2_id, 'ACond', 'Aerodynamic conductance', 'm/s',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          !-
+          !-
+          !-  Cold Season Processes
+          !-
+          CALL histdef(hist2_id, 'SnowFrac', 'Snow cover fraction', '1',  &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'SAlbedo', 'Snow albedo', '1', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          CALL histdef(hist2_id, 'SnowDepth', '3D snow depth', 'm', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, avescatter2(1), dt, dw2)
+          !-
+          !- Hydrologic variables
+          !-
+          CALL histdef(hist2_id, 'IrrigationMap', 'Map of irrigated areas', 'm^2', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(7), dt, dw2)
+          CALL histdef(hist2_id, 'dis', 'Simulated River Discharge', 'm^3/s', &
+               & iim,jjm, hori_id2, 1,1,1, -99, 32, fluxop_scinsec2(2), dt, dw2)
+          CALL histdef(hist2_id, 'humrel', 'Soil moisture stress', '1',  &
+               & iim,jjm, hori_id2, nvm,1,nvm, vegax_id2, 32, avescatter2(9), dt, dw2)
+          !-
+          !-  The carbon budget
+          !-
+          IF ( control_flags%ok_co2 ) THEN
+             CALL histdef(hist2_id, 'GPP', 'Net assimilation of carbon by the vegetation', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt, dw2)
+          ENDIF
+          IF ( control_flags%ok_stomate ) THEN
+             CALL histdef(hist2_id, 'NEE', 'Net Ecosystem Exchange', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt,dw2)
+             CALL histdef(hist2_id, 'maint_resp', 'Maintenance respiration', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt,dw2)
+             CALL histdef(hist2_id, 'hetero_resp', 'Heterotrophic respiration', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt,dw2)
+             CALL histdef(hist2_id, 'growth_resp', 'Growth respiration', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt, dw2)
+             CALL histdef(hist2_id, 'npp', 'Net Primary Production', 'gC/m^2/s', &
+                  & iim,jjm, hori_id2, nvm, 1, nvm, vegax_id2, 32, fluxop_scinsec2(1), dt, dw2)
+          ENDIF
+          !
+       ENDIF
+       !-
+       CALL histdef(hist2_id, 'LandPoints', 'Land Points', '1', &
+            & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt, dw2)  
+       CALL histdef(hist2_id, 'Areas', 'Mesh areas', 'm2', &
+            & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt, dw2)
+       CALL histdef(hist2_id, 'Contfrac', 'Continental fraction', '1', &
+            & iim,jjm, hori_id2, 1,1,1, -99, 32, once2(1), dt, dw2)
+       !-
+       CALL histend(hist2_id)
+    ENDIF
+    !-
+    !=====================================================================
+    !- 3.2 STOMATE's history file
+    !=====================================================================
+    IF ( control_flags%ok_stomate ) THEN
+       !-
+       ! STOMATE IS ACTIVATED
+       !-
+       !Config  Key  = STOMATE_OUTPUT_FILE
+       !Config  Desc = Name of file in which STOMATE's output is going
+       !Config         to be written
+       !Config  Def  = stomate_history.nc
+       !Config  Help = This file is going to be created by the model
+       !Config         and will contain the output from the model.
+       !Config         This file is a truly COADS compliant netCDF file.
+       !Config         It will be generated by the hist software from
+       !Config         the IOIPSL package.
+       !-
+       stom_histname='stomate_history.nc'
+       CALL getin_p('STOMATE_OUTPUT_FILE', stom_histname)       
+       WRITE(numout,*) 'STOMATE_OUTPUT_FILE', TRIM(stom_histname)
+       !-
+       !Config  Key  = STOMATE_HIST_DT
+       !Config  Desc = STOMATE history time step (d)
+       !Config  Def  = 10.
+       !Config  Help = Time step of the STOMATE history file
+       !-
+       hist_days_stom = 10.
+       CALL getin_p('STOMATE_HIST_DT', hist_days_stom)       
+       IF ( hist_days_stom == moins_un ) THEN
+          hist_dt_stom = moins_un
+          WRITE(numout,*) 'output frequency for STOMATE history file (d): one month.'
+       ELSE
+          hist_dt_stom = NINT( hist_days_stom ) * one_day
+          WRITE(numout,*) 'output frequency for STOMATE history file (d): ', &
+               hist_dt_stom/one_day
+       ENDIF
+
+       ! test consistency between STOMATE_HIST_DT and DT_SLOW parameters
+       dt_slow_ = one_day
+       CALL getin_p('DT_SLOW', dt_slow_)
+       IF ( hist_days_stom /= moins_un ) THEN
+          IF (dt_slow_ > hist_dt_stom) THEN
+             WRITE(numout,*) "DT_SLOW = ",dt_slow_,"  , STOMATE_HIST_DT = ",hist_dt_stom
+             CALL ipslerr (3,'intsurf_history', &
+                  &          'Problem with DT_SLOW > STOMATE_HIST_DT','', &
+                  &          '(must be less or equal)')
+          ENDIF
+       ENDIF
+       !-
+       !- initialize
+       IF ( rectilinear ) THEN
+#ifdef CPP_PARA
+          CALL histbeg(stom_histname, iim, lon_rect, jjm, lat_rect,  1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id_stom,domain_id=orch_domain_id)
+#else
+          CALL histbeg(stom_histname, iim, lon_rect, jjm, lat_rect,  1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id_stom)
+#endif
+       ELSE
+#ifdef CPP_PARA
+          CALL histbeg(stom_histname, iim, lon, jjm, lat,  1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id_stom,domain_id=orch_domain_id)
+#else
+          CALL histbeg(stom_histname, iim, lon, jjm, lat,  1, iim, 1, jjm, &
+               &     istp_old, date0, dt, hori_id, hist_id_stom)
+#endif
+       ENDIF
+       !- define PFT axis
+       hist_PFTaxis = (/ ( REAL(i,r_std), i=1,nvm ) /)
+       !- declare this axis
+       CALL histvert (hist_id_stom, 'PFT', 'Plant functional type', &
+            & '1', nvm, hist_PFTaxis, hist_PFTaxis_id)
+! deforestation
+       !- define Pool_10 axis
+       hist_pool_10axis = (/ ( REAL(i,r_std), i=1,10 ) /)
+       !- declare this axis
+       CALL histvert (hist_id_stom, 'P10', 'Pool 10 years', &
+            & '1', 10, hist_pool_10axis, hist_pool_10axis_id)
+
+       !- define Pool_100 axis
+       hist_pool_100axis = (/ ( REAL(i,r_std), i=1,100 ) /)
+       !- declare this axis
+       CALL histvert (hist_id_stom, 'P100', 'Pool 100 years', &
+            & '1', 100, hist_pool_100axis, hist_pool_100axis_id)
+
+       !- define Pool_11 axis
+       hist_pool_11axis = (/ ( REAL(i,r_std), i=1,11 ) /)
+       !- declare this axis
+       CALL histvert (hist_id_stom, 'P11', 'Pool 10 years + 1', &
+            & '1', 11, hist_pool_11axis, hist_pool_11axis_id)
+
+       !- define Pool_101 axis
+       hist_pool_101axis = (/ ( REAL(i,r_std), i=1,101 ) /)
+       !- declare this axis
+       CALL histvert (hist_id_stom, 'P101', 'Pool 100 years + 1', &
+            & '1', 101, hist_pool_101axis, hist_pool_101axis_id)
+
+       !- define STOMATE history file
+       CALL stom_define_history (hist_id_stom, nvm, iim, jjm, &
+            & dt, hist_dt_stom, hori_id, hist_PFTaxis_id, &
+            & hist_pool_10axis_id, hist_pool_100axis_id, &
+            & hist_pool_11axis_id, hist_pool_101axis_id)
+! deforestation axis added as arguments
+
+       !- end definition
+       CALL histend(hist_id_stom)
+       !-
+       !-
+       !-
+       ! STOMATE IPCC OUTPUTS IS ACTIVATED
+       !-
+       !Config  Key  = STOMATE_IPCC_OUTPUT_FILE
+       !Config  Desc = Name of file in which STOMATE's output is going
+       !Config         to be written
+       !Config  Def  = stomate_ipcc_history.nc
+       !Config  Help = This file is going to be created by the model
+       !Config         and will contain the output from the model.
+       !Config         This file is a truly COADS compliant netCDF file.
+       !Config         It will be generated by the hist software from
+       !Config         the IOIPSL package.
+       !-
+       stom_ipcc_histname='stomate_ipcc_history.nc'
+       CALL getin_p('STOMATE_IPCC_OUTPUT_FILE', stom_ipcc_histname)       
+       WRITE(numout,*) 'STOMATE_IPCC_OUTPUT_FILE', TRIM(stom_ipcc_histname)
+       !-
+       !Config  Key  = STOMATE_IPCC_HIST_DT
+       !Config  Desc = STOMATE IPCC history time step (d)
+       !Config  Def  = 0.
+       !Config  Help = Time step of the STOMATE IPCC history file
+       !-
+       hist_days_stom_ipcc = zero
+       CALL getin_p('STOMATE_IPCC_HIST_DT', hist_days_stom_ipcc)       
+       IF ( hist_days_stom_ipcc == moins_un ) THEN
+          hist_dt_stom_ipcc = moins_un
+          WRITE(numout,*) 'output frequency for STOMATE IPCC history file (d): one month.'
+       ELSE
+          hist_dt_stom_ipcc = NINT( hist_days_stom_ipcc ) * one_day
+          WRITE(numout,*) 'output frequency for STOMATE IPCC history file (d): ', &
+            hist_dt_stom_ipcc/one_day
+       ENDIF
+
+       ! test consistency between STOMATE_IPCC_HIST_DT and DT_SLOW parameters
+       dt_slow_ = one_day
+       CALL getin_p('DT_SLOW', dt_slow_)
+       IF ( hist_days_stom_ipcc > zero ) THEN
+          IF (dt_slow_ > hist_dt_stom_ipcc) THEN
+             WRITE(numout,*) "DT_SLOW = ",dt_slow_,"  , STOMATE_IPCC_HIST_DT = ",hist_dt_stom_ipcc
+             CALL ipslerr (3,'intsurf_history', &
+                  &          'Problem with DT_SLOW > STOMATE_IPCC_HIST_DT','', &
+                  &          '(must be less or equal)')
+          ENDIF
+       ENDIF
+
+       IF ( hist_dt_stom_ipcc == 0 ) THEN
+          hist_id_stom_ipcc = -1
+       ELSE
+          !-
+          !- initialize
+          IF ( rectilinear ) THEN
+#ifdef CPP_PARA
+             CALL histbeg(stom_ipcc_histname, iim, lon_rect, jjm, lat_rect,  1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id, hist_id_stom_ipcc,domain_id=orch_domain_id)
+#else
+             CALL histbeg(stom_ipcc_histname, iim, lon_rect, jjm, lat_rect,  1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id, hist_id_stom_ipcc)
+#endif
+          ELSE
+#ifdef CPP_PARA
+             CALL histbeg(stom_ipcc_histname, iim, lon, jjm, lat,  1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id, hist_id_stom_ipcc,domain_id=orch_domain_id)
+#else
+             CALL histbeg(stom_ipcc_histname, iim, lon, jjm, lat,  1, iim, 1, jjm, &
+                  &     istp_old, date0, dt, hori_id, hist_id_stom_ipcc)
+#endif
+          ENDIF
+          !- declare this axis
+          CALL histvert (hist_id_stom_IPCC, 'PFT', 'Plant functional type', &
+               & '1', nvm, hist_PFTaxis, hist_IPCC_PFTaxis_id)
+
+          !- define STOMATE history file
+          CALL stom_IPCC_define_history (hist_id_stom_IPCC, nvm, iim, jjm, &
+               & dt, hist_dt_stom_ipcc, hori_id, hist_IPCC_PFTaxis_id)
+
+          !- end definition
+          CALL histend(hist_id_stom_IPCC)
+          
+       ENDIF
+    ENDIF
+
+
+    RETURN
+
+  END SUBROUTINE intsurf_history
+  !  
+  SUBROUTINE stom_define_history &
+       & (hist_id_stom, nvm, iim, jjm, dt, &
+       &  hist_dt, hist_hori_id, hist_PFTaxis_id, &
+       & hist_pool_10axis_id, hist_pool_100axis_id, &
+       & hist_pool_11axis_id, hist_pool_101axis_id)
+    ! deforestation axis added as arguments
+
+    !---------------------------------------------------------------------
+    !- Tell ioipsl which variables are to be written
+    !- and on which grid they are defined
+    !---------------------------------------------------------------------
+    IMPLICIT NONE
+    !-
+    !- Input
+    !-
+    !- File id
+    INTEGER(i_std),INTENT(in) :: hist_id_stom
+    !- number of PFTs
+    INTEGER(i_std),INTENT(in) :: nvm
+    !- Domain size
+    INTEGER(i_std),INTENT(in) :: iim, jjm
+    !- Time step of STOMATE (seconds)
+    REAL(r_std),INTENT(in)    :: dt
+    !- Time step of history file (s)
+    REAL(r_std),INTENT(in)    :: hist_dt
+    !- id horizontal grid
+    INTEGER(i_std),INTENT(in) :: hist_hori_id
+    !- id of PFT axis
+    INTEGER(i_std),INTENT(in) :: hist_PFTaxis_id
+    !- id of Deforestation axis
+    INTEGER(i_std),INTENT(in) :: hist_pool_10axis_id,hist_pool_100axis_id
+    INTEGER(i_std),INTENT(in) :: hist_pool_11axis_id,hist_pool_101axis_id
+    !-
+    !- 1 local
+    !-
+    !- maximum history level
+    INTEGER(i_std), PARAMETER  :: max_hist_level = 10
+    !- output level (between 0 and 10)
+    !-  ( 0:nothing is written, 10:everything is written)
+    INTEGER(i_std)             :: hist_level
+    !- Character strings to define operations for histdef
+    CHARACTER(LEN=40),DIMENSION(max_hist_level) :: ave
+
+    !---------------------------------------------------------------------
+    !=====================================================================
+    !- 1 history level
+    !=====================================================================
+    !- 1.1 define history levelx
+    !=====================================================================
+    !Config  Key  = STOMATE_HISTLEVEL
+    !Config  Desc = STOMATE history output level (0..10)
+    !Config  Def  = 10
+    !Config  Help = 0: nothing is written; 10: everything is written
+    !-
+    hist_level = 10
+    CALL getin_p('STOMATE_HISTLEVEL', hist_level)
+    !-
+    WRITE(numout,*) 'STOMATE history level: ',hist_level
+    IF ( (hist_level > max_hist_level).OR.(hist_level < 0) ) THEN
+       STOP 'This history level is not allowed'
+    ENDIF
+    !=====================================================================
+    !- 1.2 define operations according to output level
+    !=====================================================================
+    ave(1:hist_level) =  'ave(scatter(X))'
+    ave(hist_level+1:max_hist_level) =  'never          '
+    !=====================================================================
+    !- 2 surface fields (2d)
+    !- 3 PFT: 3rd dimension
+    !=====================================================================
+
+
+    ! structural litter above ground
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LITTER_STR_AB       "), &
+         &               TRIM("structural litter above ground                    "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! metabolic litter above ground                     
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LITTER_MET_AB       "), &
+         &               TRIM("metabolic litter above ground                     "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! structural litter below ground               
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LITTER_STR_BE       "), &
+         &               TRIM("structural litter below ground                    "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! metabolic litter below ground                
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LITTER_MET_BE       "), &
+         &               TRIM("metabolic litter below ground                     "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! fraction of soil covered by dead leaves           
+    CALL histdef (hist_id_stom, &
+         &               TRIM("DEADLEAF_COVER      "), &
+         &               TRIM("fraction of soil covered by dead leaves           "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(5), dt, hist_dt)
+
+    ! total soil and litter carbon
+    CALL histdef (hist_id_stom, &
+         &               TRIM("TOTAL_SOIL_CARB     "), &
+         &               TRIM("total soil and litter carbon                      "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! active soil carbon in ground                 
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CARBON_ACTIVE       "), &
+         &               TRIM("active soil carbon in ground                      "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! slow soil carbon in ground                   
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CARBON_SLOW         "), &
+         &               TRIM("slow soil carbon in ground                        "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! passive soil carbon in ground                
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CARBON_PASSIVE      "), &
+         &               TRIM("passive soil carbon in ground                     "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! Long term 2 m temperature                           
+    CALL histdef (hist_id_stom, &
+         &               TRIM("T2M_LONGTERM        "), &
+         &               TRIM("Longterm 2 m temperature                          "), &
+         &               TRIM("K                   "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(9), dt, hist_dt)
+
+    ! Monthly 2 m temperature                           
+    CALL histdef (hist_id_stom, &
+         &               TRIM("T2M_MONTH           "), &
+         &               TRIM("Monthly 2 m temperature                           "), &
+         &               TRIM("K                   "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    ! Weekly 2 m temperature                            
+    CALL histdef (hist_id_stom, &
+         &               TRIM("T2M_WEEK            "), &
+         &               TRIM("Weekly 2 m temperature                            "), &
+         &               TRIM("K                   "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    ! heterotr. resp. from ground                  
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HET_RESP            "), &
+         &               TRIM("heterotr. resp. from ground                       "), &
+         &               TRIM("gC/m^2 tot/pft/day  "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+    ! black carbon on average total ground              
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BLACK_CARBON        "), &
+         &               TRIM("black carbon on average total ground              "), &
+         &               TRIM("gC/m^2 tot          "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(10), dt, hist_dt)
+
+    ! Fire fraction on ground
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FIREFRAC            "), &
+         &               TRIM("Fire fraction on ground                           "), &
+         &               TRIM("1/day               "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! Fire index on ground                      
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FIREINDEX           "), &
+         &               TRIM("Fire index on ground                              "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(10), dt, hist_dt)
+
+    ! Litter humidity                                   
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LITTERHUM           "), &
+         &               TRIM("Litter humidity                                   "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(5), dt, hist_dt)
+
+    ! CO2 flux                                  
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CO2FLUX             "), &
+         &               TRIM("CO2 flux                                          "), &
+         &               TRIM("gC/m^2/pft/mth      "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+!!$    CALL histdef(hist_id_stom, &
+!!$         &               TRIM("CO2FLUX_MONTHLY_SUM "), &
+!!$         &               TRIM("Monthly CO2 flux Sum                              "), &
+!!$         &               TRIM("PgC/m^2/mth         "), iim,jjm, hist_hori_id, &
+!!$         &               1,1,1, -99, 32, 'inst(scatter(X))', dt, hist_dt)
+
+    ! Output CO2 flux from fire                         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CO2_FIRE            "), &
+         &               TRIM("Output CO2 flux from fire                         "), &
+         &               TRIM("gC/day/m^2/pft      "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! CO2 taken from atmosphere for initiate growth     
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CO2_TAKEN           "), &
+         &               TRIM("CO2 taken from atmosphere for initiate growth     "), &
+         &               TRIM("gC/day/m^2/pft      "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! Leaf Area Index                                   
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LAI                 "), &
+         &               TRIM("Leaf Area Index                                   "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! Vegetation fraction                               
+    CALL histdef (hist_id_stom, &
+         &               TRIM("VEGET               "), &
+         &               TRIM("Vegetation fraction                               "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! Maximum vegetation fraction (LAI -> infinity)     
+    CALL histdef (hist_id_stom, &
+         &               TRIM("VEGET_MAX           "), &
+         &               TRIM("Maximum vegetation fraction (LAI -> infinity)     "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! Net primary productivity                          
+    CALL histdef (hist_id_stom, &
+         &               TRIM("NPP                 "), &
+         &               TRIM("Net primary productivity                          "), &
+         &               TRIM("gC/day/(m^2 tot)    "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! Gross primary productivity                        
+    CALL histdef (hist_id_stom, &
+         &               TRIM("GPP                 "), &
+         &               TRIM("Gross primary productivity                        "), &
+         &               TRIM("gC/day/m^2          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+    ! Density of individuals                            
+    CALL histdef (hist_id_stom, &
+         &               TRIM("IND                 "), &
+         &               TRIM("Density of individuals                            "), &
+         &               TRIM("1/ m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+    ! total living biomass
+    CALL histdef (hist_id_stom, &
+         &               TRIM("TOTAL_M             "), &
+         &               TRIM("Total living biomass                              "), &
+         &               TRIM("gC/m^2/pft          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Leaf mass                                         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LEAF_M              "), &
+         &               TRIM("Leaf mass                                         "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Sap mass above ground                             
+    CALL histdef (hist_id_stom, &
+         &               TRIM("SAP_M_AB            "), &
+         &               TRIM("Sap mass above ground                             "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Sap mass below ground                             
+    CALL histdef (hist_id_stom, &
+         &               TRIM("SAP_M_BE            "), &
+         &               TRIM("Sap mass below ground                             "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Heartwood mass above ground                       
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HEART_M_AB          "), &
+         &               TRIM("Heartwood mass above ground                       "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Heartwood mass below ground                       
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HEART_M_BE          "), &
+         &               TRIM("Heartwood mass below ground                       "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Root mass                                         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("ROOT_M              "), &
+         &               TRIM("Root mass                                         "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Fruit mass                                        
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FRUIT_M             "), &
+         &               TRIM("Fruit mass                                        "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Carbohydrate reserve mass                         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("RESERVE_M           "), &
+         &               TRIM("Carbohydrate reserve mass                         "), &
+         &               TRIM("gC/m^2              "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! total turnover rate
+    CALL histdef (hist_id_stom, &
+         &               TRIM("TOTAL_TURN          "), &
+         &               TRIM("total turnover rate                               "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Leaf turnover                                     
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LEAF_TURN           "), &
+         &               TRIM("Leaf turnover                                     "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Sap turnover above                                
+    CALL histdef (hist_id_stom, &
+         &               TRIM("SAP_AB_TURN         "), &
+         &               TRIM("Sap turnover above                                "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Root turnover                                     
+    CALL histdef (hist_id_stom, &
+         &               TRIM("ROOT_TURN           "), &
+         &               TRIM("Root turnover                                     "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Fruit turnover                                    
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FRUIT_TURN          "), &
+         &               TRIM("Fruit turnover                                    "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! total conversion of biomass to litter 
+    CALL histdef (hist_id_stom, &
+         &               TRIM("TOTAL_BM_LITTER     "), &
+         &               TRIM("total conversion of biomass to litter             "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Leaf death                                        
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LEAF_BM_LITTER      "), &
+         &               TRIM("Leaf death                                        "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Sap death above ground                            
+    CALL histdef (hist_id_stom, &
+         &               TRIM("SAP_AB_BM_LITTER    "), &
+         &               TRIM("Sap death above ground                            "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Sap death below ground                            
+    CALL histdef (hist_id_stom, &
+         &               TRIM("SAP_BE_BM_LITTER    "), &
+         &               TRIM("Sap death below ground                            "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Heartwood death above ground                      
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HEART_AB_BM_LITTER  "), &
+         &               TRIM("Heartwood death above ground                      "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Heartwood death below ground                      
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HEART_BE_BM_LITTER  "), &
+         &               TRIM("Heartwood death below ground                      "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Root death                                        
+    CALL histdef (hist_id_stom, &
+         &               TRIM("ROOT_BM_LITTER      "), &
+         &               TRIM("Root death                                        "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Fruit death                                       
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FRUIT_BM_LITTER     "), &
+         &               TRIM("Fruit death                                       "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Carbohydrate reserve death                        
+    CALL histdef (hist_id_stom, &
+         &               TRIM("RESERVE_BM_LITTER   "), &
+         &               TRIM("Carbohydrate reserve death                        "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(4), dt, hist_dt)
+
+    ! Maintenance respiration                           
+    CALL histdef (hist_id_stom, &
+         &               TRIM("MAINT_RESP          "), &
+         &               TRIM("Maintenance respiration                           "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! Growth respiration                                
+    CALL histdef (hist_id_stom, &
+         &               TRIM("GROWTH_RESP         "), &
+         &               TRIM("Growth respiration                                "), &
+         &               TRIM("gC/m^2/day          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(2), dt, hist_dt)
+
+    ! age                                               
+    CALL histdef (hist_id_stom, &
+         &               TRIM("AGE                 "), &
+         &               TRIM("age                                               "), &
+         &               TRIM("years               "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(7), dt, hist_dt)
+
+    ! height                                            
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HEIGHT              "), &
+         &               TRIM("height                                            "), &
+         &               TRIM("m                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(7), dt, hist_dt)
+
+    ! weekly moisture stress                            
+    CALL histdef (hist_id_stom, &
+         &               TRIM("MOISTRESS           "), &
+         &               TRIM("weekly moisture stress                            "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(3), dt, hist_dt)
+
+    ! Maximum rate of carboxylation                     
+    CALL histdef (hist_id_stom, &
+         &               TRIM("VCMAX               "), &
+         &               TRIM("Maximum rate of carboxylation                     "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
+
+    ! leaf age                                          
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LEAF_AGE            "), &
+         &               TRIM("leaf age                                          "), &
+         &               TRIM("days                "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
+
+    ! Fraction of trees that dies (gap)                 
+    CALL histdef (hist_id_stom, &
+         &               TRIM("MORTALITY           "), &
+         &               TRIM("Fraction of trees that dies (gap)                 "), &
+         &               TRIM("1/day               "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
+
+    ! Fraction of plants killed by fire                 
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FIREDEATH           "), &
+         &               TRIM("Fraction of plants killed by fire                 "), &
+         &               TRIM("1/day               "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
+
+    ! Density of newly established saplings             
+    CALL histdef (hist_id_stom, &
+         &               TRIM("IND_ESTAB           "), &
+         &               TRIM("Density of newly established saplings             "), &
+         &               TRIM("1/day               "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
+
+    ! Fraction of plants that dies (light competition)  
+    CALL histdef (hist_id_stom, &
+         &               TRIM("LIGHT_DEATH         "), &
+         &               TRIM("Fraction of plants that dies (light competition)  "), &
+         &               TRIM("1/day               "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(6), dt, hist_dt)
+
+    ! biomass allocated to leaves                       
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BM_ALLOC_LEAF       "), &
+         &               TRIM("biomass allocated to leaves                       "), &
+         &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! biomass allocated to sapwood above ground         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BM_ALLOC_SAP_AB     "), &
+         &               TRIM("biomass allocated to sapwood above ground         "), &
+         &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! biomass allocated to sapwood below ground         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BM_ALLOC_SAP_BE     "), &
+         &               TRIM("biomass allocated to sapwood below ground         "), &
+         &               TRIM("gC/m**2/pft/dt      "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! biomass allocated to roots                        
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BM_ALLOC_ROOT       "), &
+         &               TRIM("biomass allocated to roots                        "), &
+         &               TRIM("gC/m**2/pft/dt          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! biomass allocated to fruits                       
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BM_ALLOC_FRUIT      "), &
+         &               TRIM("biomass allocated to fruits                       "), &
+         &               TRIM("gC/m**2/pft/dt          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! biomass allocated to carbohydrate reserve         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BM_ALLOC_RES        "), &
+         &               TRIM("biomass allocated to carbohydrate reserve         "), &
+         &               TRIM("gC/m**2/pft/dt          "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! time constant of herbivore activity               
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HERBIVORES          "), &
+         &               TRIM("time constant of herbivore activity               "), &
+         &               TRIM("days                "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! turnover time for grass leaves                    
+    CALL histdef (hist_id_stom, &
+         &               TRIM("TURNOVER_TIME       "), &
+         &               TRIM("turnover time for grass leaves                    "), &
+         &               TRIM("days                "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(5), dt, hist_dt)
+
+    ! 10 year wood product pool                         
+    CALL histdef (hist_id_stom, &
+         &               TRIM("PROD10              "), &
+         &               TRIM("10 year wood product pool                         "), &
+         &               TRIM("gC/m**2             "), iim,jjm, hist_hori_id, &
+         &               11,1,11, hist_pool_11axis_id,32, ave(5), dt, hist_dt)
+
+    ! annual flux for each 10 year wood product pool    
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FLUX10              "), &
+         &               TRIM("annual flux for each 10 year wood product pool    "), &
+         &               TRIM("gC/m**2/yr          "), iim,jjm, hist_hori_id, &
+         &               10,1,10, hist_pool_10axis_id,32, ave(5), dt, hist_dt)
+
+    ! 100 year wood product pool                        
+    CALL histdef (hist_id_stom, &
+         &               TRIM("PROD100             "), &
+         &               TRIM("100 year wood product pool                        "), &
+         &               TRIM("gC/m**2             "), iim,jjm, hist_hori_id, &
+         &               101,1,101, hist_pool_101axis_id,32, ave(5), dt, hist_dt)
+
+    ! annual flux for each 100 year wood product pool   
+    CALL histdef (hist_id_stom, &
+         &               TRIM("FLUX100             "), &
+         &               TRIM("annual flux for each 100 year wood product pool   "), &
+         &               TRIM("gC/m**2/yr          "), iim,jjm, hist_hori_id, &
+         &               100,1,100, hist_pool_100axis_id,32, ave(5), dt, hist_dt)
+
+    ! annual release right after deforestation          
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CONVFLUX            "), &
+         &               TRIM("annual release right after deforestation          "), &
+         &               TRIM("gC/m**2/day          "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(5), dt, hist_dt)
+
+    ! annual release from all 10 year wood product pools 
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CFLUX_PROD10        "), &
+         &               TRIM("annual release from all 10 year wood product pools"), &
+         &               TRIM("gC/m**2/day          "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(5), dt, hist_dt)
+
+    ! annual release from all 100year wood product pools
+    CALL histdef (hist_id_stom, &
+         &               TRIM("CFLUX_PROD100       "), &
+         &               TRIM("annual release from all 100year wood product pools"), &
+         &               TRIM("gC/m**2/day          "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(5), dt, hist_dt)
+    ! agriculure product
+    CALL histdef (hist_id_stom, &
+         &               TRIM("HARVEST_ABOVE       "), &
+         &               TRIM("annual release product after harvest              "), &
+         &               TRIM("gC/m**2/day          "), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(5), dt, hist_dt)
+
+
+    CALL histdef(hist_id_stom, 'RESOLUTION_X', 'E-W resolution', 'm', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+    CALL histdef(hist_id_stom, 'RESOLUTION_Y', 'N-S resolution', 'm', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+    CALL histdef(hist_id_stom, 'CONTFRAC', 'Continental fraction', '1', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+    CALL histdef(hist_id_stom, 'Areas', 'Mesh areas', 'm2', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+
+    !  Special outputs for phenology
+    CALL histdef (hist_id_stom, &
+         &               TRIM("WHEN_GROWTHINIT     "), &
+         &               TRIM("Time elapsed from season beginning                "), &
+         &               TRIM("d                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(9), dt, hist_dt)
+
+    CALL histdef (hist_id_stom, &
+         &               TRIM("TIME_LOWGPP         "), &
+         &               TRIM("Time elapsed since the end of GPP                 "), &
+         &               TRIM("d                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(9), dt, hist_dt)
+
+    CALL histdef (hist_id_stom, &
+         &               TRIM("PFTPRESENT          "), &
+         &               TRIM("PFT exists                                        "), &
+         &               TRIM("d                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(9), dt, hist_dt)
+
+    CALL histdef (hist_id_stom, &
+         &               TRIM("GDD_MIDWINTER       "), &
+         &               TRIM("Growing degree days, since midwinter              "), &
+         &               TRIM("degK                "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(9), dt, hist_dt)
+
+    CALL histdef (hist_id_stom, &
+         &               TRIM("NCD_DORMANCE        "), &
+         &               TRIM("Number of chilling days, since leaves were lost   "), &
+         &               TRIM("d                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(9), dt, hist_dt)
+
+    CALL histdef (hist_id_stom, &
+         &               TRIM("ALLOW_INITPHENO     "), &
+         &               TRIM("Allow to declare beginning of the growing season  "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(9), dt, hist_dt)
+
+    CALL histdef (hist_id_stom, &
+         &               TRIM("BEGIN_LEAVES        "), &
+         &               TRIM("Signal to start putting leaves on                 "), &
+         &               TRIM("-                   "), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(9), dt, hist_dt)
+
+    !---------------------------------
+  END SUBROUTINE stom_define_history
+  !
+  SUBROUTINE stom_IPCC_define_history &
+       & (hist_id_stom_IPCC, nvm, iim, jjm, dt, &
+       &  hist_dt, hist_hori_id, hist_PFTaxis_id)
+    ! deforestation axis added as arguments
+
+    !---------------------------------------------------------------------
+    !- Tell ioipsl which variables are to be written
+    !- and on which grid they are defined
+    !---------------------------------------------------------------------
+    IMPLICIT NONE
+    !-
+    !- Input
+    !-
+    !- File id
+    INTEGER(i_std),INTENT(in) :: hist_id_stom_IPCC
+    !- number of PFTs
+    INTEGER(i_std),INTENT(in) :: nvm
+    !- Domain size
+    INTEGER(i_std),INTENT(in) :: iim, jjm
+    !- Time step of STOMATE (seconds)
+    REAL(r_std),INTENT(in)    :: dt
+    !- Time step of history file (s)
+    REAL(r_std),INTENT(in)    :: hist_dt
+    !- id horizontal grid
+    INTEGER(i_std),INTENT(in) :: hist_hori_id
+    !- id of PFT axis
+    INTEGER(i_std),INTENT(in) :: hist_PFTaxis_id
+    !-
+    !- 1 local
+    !-
+    !- Character strings to define operations for histdef
+    CHARACTER(LEN=40),DIMENSION(max_hist_level) :: ave
+
+    !=====================================================================
+    !- 1 define operations
+    !=====================================================================
+    ave(1) =  'ave(scatter(X))'
+    !=====================================================================
+    !- 2 surface fields (2d)
+    !=====================================================================
+    ! Carbon in Vegetation
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cVeg"), &
+         &               TRIM("Carbon in Vegetation"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Litter Pool
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cLitter"), &
+         &               TRIM("Carbon in Litter Pool"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Soil Pool
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cSoil"), &
+         &               TRIM("Carbon in Soil Pool"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Products of Land Use Change
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cProduct"), &
+         &               TRIM("Carbon in Products of Land Use Change"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Leaf Area Fraction
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("lai"), &
+         &               TRIM("Leaf Area Fraction"), &
+         &               TRIM("1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Gross Primary Production
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("gpp"), &
+         &               TRIM("Gross Primary Production"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Autotrophic Respiration
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("ra"), &
+         &               TRIM("Autotrophic Respiration"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Net Primary Production
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("npp"), &
+         &               TRIM("Net Primary Production"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Heterotrophic Respiration
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("rh"), &
+         &               TRIM("Heterotrophic Respiration"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! CO2 Emission from Fire
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("fFire"), &
+         &               TRIM("CO2 Emission from Fire"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    ! CO2 Flux to Atmosphere from Crop Harvesting
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("fHarvest"), &
+         &               TRIM("CO2 Flux to Atmosphere from Crop Harvesting"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! CO2 Flux to Atmosphere from Land Use Change
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("fLuc"), &
+         &               TRIM("CO2 Flux to Atmosphere from Land Use Change"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Net Biospheric Production
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("nbp"), &
+         &               TRIM("Net Biospheric Production"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Total Carbon Flux from Vegetation to Litter
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("fVegLitter"), &
+         &               TRIM("Total Carbon Flux from Vegetation to Litter"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Total Carbon Flux from Litter to Soil
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("fLitterSoil"), &
+         &               TRIM("Total Carbon Flux from Litter to Soil"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    ! Carbon in Leaves
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cLeaf"), &
+         &               TRIM("Carbon in Leaves"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Wood
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cWood"), &
+         &               TRIM("Carbon in Wood"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Roots
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cRoot"), &
+         &               TRIM("Carbon in Roots"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Other Living Compartments
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cMisc"), &
+         &               TRIM("Carbon in Other Living Compartments"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    ! Carbon in Above-Ground Litter
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cLitterAbove"), &
+         &               TRIM("Carbon in Above-Ground Litter"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Below-Ground Litter
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cLitterBelow"), &
+         &               TRIM("Carbon in Below-Ground Litter"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Fast Soil Pool
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cSoilFast"), &
+         &               TRIM("Carbon in Fast Soil Pool"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Medium Soil Pool
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cSoilMedium"), &
+         &               TRIM("Carbon in Medium Soil Pool"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Carbon in Slow Soil Pool
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("cSoilSlow"), &
+         &               TRIM("Carbon in Slow Soil Pool"), &
+         &               TRIM("kg C m-2"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    !- 3 PFT: 3rd dimension
+    ! Fractional Land Cover of PFT
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("landCoverFrac"), &
+         &               TRIM("Fractional Land Cover of PFT"), &
+         &               TRIM("%"), iim,jjm, hist_hori_id, &
+         &               nvm,1,nvm, hist_PFTaxis_id,32, ave(1), dt, hist_dt)
+
+
+    ! Total Primary Deciduous Tree Cover Fraction
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("treeFracPrimDec"), &
+         &               TRIM("Total Primary Deciduous Tree Cover Fraction"), &
+         &               TRIM("%"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    ! Total Primary Evergreen Tree Cover Fraction
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("treeFracPrimEver"), &
+         &               TRIM("Total Primary Evergreen Tree Cover Fraction"), &
+         &               TRIM("%"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    ! Total C3 PFT Cover Fraction
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("c3PftFrac"), &
+         &               TRIM("Total C3 PFT Cover Fraction"), &
+         &               TRIM("%"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Total C4 PFT Cover Fraction
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("c4PftFrac"), &
+         &               TRIM("Total C4 PFT Cover Fraction"), &
+         &               TRIM("%"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Growth Autotrophic Respiration
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("rGrowth"), &
+         &               TRIM("Growth Autotrophic Respiration"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Maintenance Autotrophic Respiration
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("rMaint"), &
+         &               TRIM("Maintenance Autotrophic Respiration"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! CO2 Flux from Atmosphere due to NPP Allocation to Leaf
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("nppLeaf"), &
+         &               TRIM("CO2 Flux from Atmosphere due to NPP Allocation to Leaf"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! CO2 Flux from Atmosphere due to NPP Allocation to Wood
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("nppWood"), &
+         &               TRIM("CO2 Flux from Atmosphere due to NPP Allocation to Wood"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! CO2 Flux from Atmosphere due to NPP Allocation to Root
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("nppRoot"), &
+         &               TRIM("CO2 Flux from Atmosphere due to NPP Allocation to Root"), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+    ! Net Carbon Mass Flux out of Atmophere due to Net Ecosystem Productivity on Land.
+    CALL histdef (hist_id_stom_IPCC, &
+         &               TRIM("nep"), &
+         &               TRIM("Net Carbon Mass Flux out of Atmophere due to Net Ecosystem Productivity."), &
+         &               TRIM("kg C m-2 s-1"), iim,jjm, hist_hori_id, &
+         &               1,1,1, -99,32, ave(1), dt, hist_dt)
+
+    CALL histdef(hist_id_stom_IPCC, 'RESOLUTION_X', 'E-W resolution', 'm', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+    CALL histdef(hist_id_stom_IPCC, 'RESOLUTION_Y', 'N-S resolution', 'm', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+    CALL histdef(hist_id_stom_IPCC, 'CONTFRAC', 'Continental fraction', '1', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+    CALL histdef(hist_id_stom_IPCC, 'Areas', 'Mesh areas', 'm2', &
+         & iim,jjm, hist_hori_id, 1,1,1, -99, 32, 'once(scatter(X))', dt, hist_dt)
+
+    !---------------------------------
+  END SUBROUTINE stom_IPCC_define_history
+END MODULE intersurf
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/routing.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/routing.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/routing.f90	(revision 55)
@@ -0,0 +1,5313 @@
+!!
+!!
+!! This module routes the water over the continents into the oceans.
+!!
+!! Histoire Salee
+!!---------------
+!! La douce riviere
+!! Sortant de son lit
+!! S'est jetee ma chere
+!! dans les bras mais oui
+!! du beau fleuve
+!!
+!! L'eau coule sous les ponts
+!! Et puis les flots s'emeuvent
+!! - N'etes vous pas au courant ?
+!! Il parait que la riviere 
+!! Va devenir mer
+!!                       Roland Bacri
+!!
+!! @author Jan Polcher
+!! @Version : $Revision$, $Date$
+!!
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!!
+MODULE routing
+  !
+  !
+  ! routines called : restput, restget
+  !
+  USE ioipsl   
+  !
+  USE constantes
+  USE constantes_veg
+  USE sechiba_io
+  USE grid
+  USE parallel
+  !
+  IMPLICIT NONE
+  !
+  ! public routines :
+  !
+  PRIVATE
+  PUBLIC :: routing_main, routing_clear
+  !
+  ! variables used inside hydrol module : declaration and initialisation
+  !
+  LOGICAL, SAVE                                     :: l_first_routing=.TRUE. !! Initialisation has to be done one time
+  LOGICAL, SAVE                                     :: check_waterbal=.FALSE. !! The check the water balance
+  !
+  !  The maximum number of basins we wish to have per grid-box (truncation of the model)
+  INTEGER(i_std), PARAMETER                         :: nbasmax=5
+  !  The maximum number of bassins we can handle at any time during the generation of the maps.
+  INTEGER(i_std), PARAMETER                          :: nbvmax = 220
+  !
+  !  The time constants are in days.
+  ! 
+  REAL(r_std), PARAMETER                             :: fast_tcst = 3.0, slow_tcst = 25.0, stream_tcst = 0.24 
+  REAL(r_std), PARAMETER                             :: evap_cst = 0.18, wdelay_cst = 0.7
+  !
+  !  Maximum evaporation rate from lakes 7.5 kg/m^2/d transformed into kg/m^2/sec
+  !
+  REAL(r_std), PARAMETER                             :: maxevap_lake = 7.5/86400.
+  !
+  !  Parameter for the Kassel irrigation parametrization linked to the crops
+  !
+  REAL(r_std), PARAMETER                             :: crop_coef = 1.5
+  !
+  INTEGER(i_std), PARAMETER                         :: undef_int = 999999999
+  !
+  REAL(r_std),SAVE                                   :: dt_routing
+  !
+  ! Logicals to control model configuration
+  !
+  LOGICAL, SAVE                                     :: doirrigation = .FALSE.
+  LOGICAL, SAVE                                     :: dofloodplains = .FALSE.
+  !
+  !
+  ! The variables describing the basins and their routing, need to be in the restart file.
+  !
+  INTEGER(i_std), SAVE                               :: num_largest
+  REAL(r_std), SAVE                                  :: time_counter
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: routing_area_loc
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: topo_resid_loc
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_togrid_loc
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_tobasin_loc
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: global_basinid_loc
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)          :: hydrodiag_loc    !! Variable to diagnose the hydrographs
+  !
+  ! parallelism
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: routing_area_glo
+  REAL(r_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)     :: topo_resid_glo
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_togrid_glo
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: route_tobasin_glo
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)  :: global_basinid_glo
+  INTEGER(i_std), SAVE, ALLOCATABLE, TARGET, DIMENSION(:,:)          :: hydrodiag_glo    !! Variable to diagnose the hydrographs
+
+  REAL(r_std), SAVE, POINTER, DIMENSION(:,:)     :: routing_area
+  REAL(r_std), SAVE, POINTER, DIMENSION(:,:)     :: topo_resid
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)  :: route_togrid
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)  :: route_tobasin
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)  :: global_basinid
+  INTEGER(i_std), SAVE, POINTER, DIMENSION(:,:)  :: hydrodiag
+  ! Map of irrigated areas and floodplains
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: irrigated          ! Surface which can be irrigate in each grid-box
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: floodplains        ! Surface which can be inondated in each grid-box
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)   :: previous_outflow
+  !
+  ! The reservoirs, also to be put into the restart file.
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:)   :: fast_reservoir, slow_reservoir, stream_reservoir
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: lake_reservoir
+  !
+  ! The accumulated fluxes.
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: runoff_mean, drainage_mean, evapot_mean
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: precip_mean, humrel_mean, totnobio_mean, vegtot_mean
+  !
+  ! The averaged outflow fluxes.
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: lakeinflow_mean
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: returnflow_mean, irrigation_mean
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: riverflow_mean, coastalflow_mean
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: floodtemp
+  INTEGER(i_std), SAVE                             :: floodtemp_lev
+  !
+  ! Diagnostic variables ... well sort of !
+  !
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: irrig_netereq
+  !
+  ! Hydrographs at the outflow of the grid box for major basins
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: hydrographs 
+  ! Diagnostics for the various reservoirs we use (Kg/m^2)
+  REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:)     :: fast_diag, slow_diag, stream_diag, lake_diag
+  !
+CONTAINS
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_main(kjit, nbpt, dtradia, ldrestart_read, ldrestart_write, index, &
+       & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, runoff, &
+       & drainage, evapot, precip_rain, humrel, &
+       & stempdiag, returnflow, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
+    !
+    IMPLICIT NONE
+    !
+    ! This module will route the runoff and drainage produced by the hydrol module. These two
+    ! fluxes are provided in kg/m^2dt. The result of the routing are 3 fluxes :
+    ! - riverflow   : The water which flows out from the major rivers. The flux will be located
+    !                 on the continental grid but this should be a coastal point.
+    ! - coastalflow : This is the water which flows in a disperse way into the ocean. Essentially these
+    !                 are the outflows from all the small rivers.
+    ! - returnflow  : This is the water which flows into a land-point. Typically rivers which end in
+    !                 the desert. This water will go back into the hydrol module to allow re-evaporation.
+    ! - irrigation  : This is water taken from the river reservoir and beeing put into the upper 
+    !                 layers of the soil.
+    ! The two first fluxes are in kg/dt and the last one is on kg/m^2dt.
+    !
+    INTEGER(i_std), INTENT(in)    :: kjit                !! Time step number
+    INTEGER(i_std), INTENT(in)    :: nbpt                !! Domain size
+    INTEGER(i_std),INTENT(in)     :: rest_id,hist_id     !! _Restart_ file and _history_ file identifier
+    INTEGER(i_std),INTENT(in)     :: hist2_id            !! _history_ file 2 identifier
+    REAL(r_std), INTENT(in)       :: dtradia             !! Time step in seconds
+    LOGICAL, INTENT(in)          :: ldrestart_read      !! Logical for _restart_ file to read
+    LOGICAL, INTENT(in)          :: ldrestart_write     !! Logical for _restart_ file to write
+    INTEGER(i_std), INTENT(in)    :: index(nbpt)         ! Indeces of the points on the map 
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)        ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)    :: neighbours(nbpt,8)  ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)  ! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)      ! Fraction of land in each grid box
+    REAL(r_std), INTENT(in)       :: totfrac_nobio(nbpt) ! Total fraction of continental ice+lakes+...
+    REAL(r_std), INTENT(in)       :: veget_max(nbpt,nvm) ! Maximum vegetation fraction. We want to have the 
+                                                        ! part of the grid which can have some vegetation.
+    REAL(r_std), INTENT(in)       :: runoff(nbpt)        ! grid-point runoff
+    REAL(r_std), INTENT(in)       :: drainage(nbpt)      ! grid-point drainage
+    REAL(r_std), INTENT(in)       :: evapot(nbpt)        ! Potential evaporation
+    REAL(r_std), INTENT(in)       :: precip_rain(nbpt)   ! Rainfall needed for the irrigation formula
+    REAL(r_std), INTENT(in)       :: humrel(nbpt,nvm)    ! Soil moisture stress
+    REAL(r_std), INTENT(in)       :: stempdiag(nbpt,nbdl)! Temperature profile in soil
+    !
+    REAL(r_std), INTENT(out)      :: returnflow(nbpt)    ! The water flow which returns to the grid box (kg/m^2 per dt)
+    REAL(r_std), INTENT(out)      :: irrigation(nbpt)    ! Irrigation flux (kg/m^2 per dt)
+    REAL(r_std), INTENT(out)      :: riverflow(nbpt)     ! Outflow of the major rivers
+    REAL(r_std), INTENT(out)      :: coastalflow(nbpt)   ! Outflow on coastal points by small basins    
+    !
+    ! LOCAL
+    !
+    CHARACTER(LEN=30)            :: var_name
+    REAL(r_std), DIMENSION(1)     :: tmp_day
+    REAL(r_std), DIMENSION(nbpt)  :: return_lakes
+    INTEGER(i_std)               :: ig, jv
+    LOGICAL, SAVE                 :: init_irrig=.FALSE., init_flood=.FALSE.
+    !
+    ! do initialisation
+    !
+    IF (l_first_routing) THEN
+       !
+       ! Here we will allocate the memory and get the fixed fields from the restart file.
+       ! If the info is not found then we will compute the routing map.
+       !
+       CALL routing_init (kjit, nbpt, index, dtradia, returnflow, irrigation, &
+            &             riverflow, coastalflow, stempdiag, rest_id)
+       routing_area => routing_area_loc  
+       topo_resid => topo_resid_loc
+       route_togrid => route_togrid_loc
+       route_tobasin => route_tobasin_loc
+       global_basinid => global_basinid_loc
+       hydrodiag => hydrodiag_loc
+       !
+       ! This routine computes the routing map if needed.
+       !
+       IF ( COUNT(route_togrid_glo .GE. undef_int) .GT. 0 ) THEN
+          CALL routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
+       ENDIF
+       !
+       ! Do we have what we need if we want to do irrigation
+       !
+       IF ( doirrigation .OR. dofloodplains ) THEN
+
+          IF ( doirrigation ) THEN 
+             IF (COUNT(irrigated .GE. undef_sechiba-1) > 0) THEN
+                init_irrig = .TRUE.
+             ENDIF
+          ENDIF
+
+          IF ( dofloodplains ) THEN
+             IF (COUNT(floodplains .GE. undef_sechiba-1) > 0) THEN
+                init_flood = .TRUE.
+             ENDIF
+          ENDIF
+
+          IF ( init_irrig .OR. init_flood ) THEN
+             CALL routing_irrigmap(nbpt, index, lalo, neighbours, resolution, &
+                 contfrac, init_irrig, irrigated, init_flood, floodplains, hist_id, hist2_id)
+          ENDIF
+
+       ENDIF
+       !
+       ! This routine gives a diag nostic of the basins used.
+       !
+       CALL routing_diagnostic_p(nbpt, index, resolution, contfrac, hist_id, hist2_id)
+       !
+       l_first_routing = .FALSE.
+       !
+       RETURN
+       !
+    ENDIF
+    !
+    ! Accumulate the incoming water fluxes
+    !
+    runoff_mean(:) = runoff_mean(:) + runoff(:)
+    drainage_mean(:) = drainage_mean(:) + drainage(:)
+    evapot_mean(:) = evapot_mean(:) + evapot(:)
+    floodtemp(:) = stempdiag(:,floodtemp_lev)
+    precip_mean(:) =  precip_mean(:) + precip_rain(:)
+    !
+    ! Averaged variables (i.e. *dtradia/dt_routing)
+    !
+    totnobio_mean(:) = totnobio_mean(:) + totfrac_nobio(:)*dtradia/dt_routing
+    !
+    ! Only potentially vegetated surfaces are taken into account. At the start of
+    ! the growing seasons (when veget and veget_max are still different) we will
+    ! more weight to these areas.
+    !
+    DO jv=2,nvm
+       DO ig=1,nbpt
+          humrel_mean(ig) = humrel_mean(ig) + humrel(ig,jv)*veget_max(ig,jv)*dtradia/dt_routing
+          vegtot_mean(ig) = vegtot_mean(ig) + veget_max(ig,jv)*dtradia/dt_routing
+       ENDDO
+    ENDDO
+    !
+    time_counter = time_counter + dtradia 
+    !
+    ! If the time has come we do the routing.
+    !
+    IF ( NINT(time_counter) .GE. NINT(dt_routing) ) THEN 
+       !
+       ! Check the water balance if needed
+       !
+       IF ( check_waterbal ) THEN
+          CALL routing_waterbal(nbpt, .TRUE., runoff_mean, drainage_mean, returnflow_mean, &
+               & irrigation_mean, riverflow_mean, coastalflow_mean)
+       ENDIF
+       !
+       ! Make sure we do not flood north of 49N
+       !
+       DO ig=1,nbpt
+          IF ( lalo(ig,1) > 49.0 ) THEN
+             floodtemp(ig) = tp_00 - un
+          ENDIF
+       ENDDO
+       !
+       CALL routing_flow(nbpt, dt_routing, runoff_mean, drainage_mean, &
+            & vegtot_mean, totnobio_mean, evapot_mean, precip_mean, humrel_mean, floodtemp, &
+            & lakeinflow_mean, returnflow_mean, irrigation_mean, riverflow_mean, &
+            & coastalflow_mean, hydrographs)
+       !
+       CALL routing_lake(nbpt, dt_routing, lakeinflow_mean, humrel_mean, return_lakes)
+       !
+       returnflow_mean(:) = returnflow_mean(:) + return_lakes(:)
+       !
+       ! Close the water balance if asked for
+       !
+       IF ( check_waterbal ) THEN
+          CALL routing_waterbal(nbpt, .FALSE., runoff_mean, drainage_mean, returnflow_mean, &
+               & irrigation_mean, riverflow_mean, coastalflow_mean)
+       ENDIF
+       !
+       time_counter = zero
+       !
+       runoff_mean(:) = zero
+       drainage_mean(:) = zero
+       evapot_mean(:) = zero
+       precip_mean(:) = zero
+       !
+       humrel_mean(:) = zero
+       totnobio_mean(:) = zero
+       vegtot_mean(:) = zero
+       !
+       ! Change the units of the routing fluxes from kg/dt_routing into kg/dtradia
+       !                                    and from m^3/dt_routing into m^3/dtradia
+       !
+       returnflow_mean(:) = returnflow_mean(:)/dt_routing*dtradia
+       irrigation_mean(:) = irrigation_mean(:)/dt_routing*dtradia
+       irrig_netereq(:) = irrig_netereq(:)/dt_routing*dtradia
+       !
+       !
+       riverflow_mean(:) = riverflow_mean(:)/dt_routing*dtradia
+       coastalflow_mean(:) = coastalflow_mean(:)/dt_routing*dtradia
+       hydrographs(:) = hydrographs(:)/dt_routing*dtradia
+       !
+       ! Convert from kg/dtradia to m^3/dtradia
+       !
+       hydrographs(:) = hydrographs(:)/1000.
+       !
+    ENDIF
+    !
+    ! Return the fraction of routed water for this time step.
+    !
+    returnflow(:) = returnflow_mean(:)
+    irrigation(:) = irrigation_mean(:)
+    riverflow(:) = riverflow_mean(:)
+    coastalflow(:) = coastalflow_mean(:)
+    !
+    ! Write restart
+    !
+    IF (ldrestart_write) THEN 
+       !
+       var_name ="routingcounter"
+       tmp_day(1) = time_counter
+       IF (is_root_prc) CALL restput (rest_id, var_name, 1, 1, 1, kjit, tmp_day)
+       !
+       var_name = 'routingarea'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, routing_area, 'scatter',  nbp_glo, index_g)
+       var_name = 'routetogrid'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, REAL(route_togrid,r_std), 'scatter', &
+            &        nbp_glo, index_g)
+       var_name = 'routetobasin'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, REAL(route_tobasin,r_std), 'scatter', &
+            &        nbp_glo, index_g)
+       var_name = 'basinid'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, REAL(global_basinid,r_std), 'scatter', &
+            &        nbp_glo, index_g)
+       var_name = 'topoindex'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, topo_resid, 'scatter',  nbp_glo, index_g)
+       var_name = 'fastres'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, fast_reservoir, 'scatter',  nbp_glo, index_g)
+       var_name = 'slowres'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, slow_reservoir, 'scatter',  nbp_glo, index_g)
+       var_name = 'streamres'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, stream_reservoir, 'scatter',nbp_glo,index_g)
+       !
+       var_name = 'lakeres'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, lake_reservoir, 'scatter',  nbp_glo, index_g)
+       !
+       var_name = 'lakeinflow'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, lakeinflow_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'returnflow'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, returnflow_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'riverflow'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, riverflow_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'coastalflow'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, coastalflow_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'hydrographs'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, hydrographs, 'scatter',  nbp_glo, index_g)
+       !
+       ! Keep track of the accumulated variables
+       !
+       var_name = 'runoff_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, runoff_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'drainage_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, drainage_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'evapot_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, evapot_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'precip_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, precip_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'humrel_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, humrel_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'totnobio_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, totnobio_mean, 'scatter',  nbp_glo, index_g)
+       var_name = 'vegtot_route'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, vegtot_mean, 'scatter',  nbp_glo, index_g)
+       !
+       var_name = 'previous_outflow'
+       CALL restput_p (rest_id, var_name, nbp_glo, nbasmax+3, 1, kjit,previous_outflow,'scatter',nbp_glo,index_g)
+       !
+       IF ( doirrigation ) THEN
+          var_name = 'irrigated'
+          CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, irrigated, 'scatter',  nbp_glo, index_g)
+          var_name = 'irrigation'
+          CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, irrigation_mean, 'scatter',  nbp_glo, index_g)
+       ENDIF
+       !
+       IF ( dofloodplains ) THEN
+          var_name = 'floodplains'
+          CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, floodplains, 'scatter',  nbp_glo, index_g)
+       ENDIF
+       !
+       RETURN
+       !
+    ENDIF
+    !
+    ! Write diagnostics
+    !
+    IF ( .NOT. almaoutput ) THEN
+       !
+       CALL histwrite(hist_id, 'riversret', kjit, returnflow, nbpt, index)
+       CALL histwrite(hist_id, 'hydrographs', kjit, hydrographs, nbpt, index)
+       !
+       CALL histwrite(hist_id, 'fastr', kjit, fast_diag, nbpt, index)
+       CALL histwrite(hist_id, 'slowr', kjit, slow_diag, nbpt, index)
+       CALL histwrite(hist_id, 'streamr', kjit, stream_diag, nbpt, index)
+       CALL histwrite(hist_id, 'lakevol', kjit, lake_diag, nbpt, index)
+       !
+       CALL histwrite(hist_id, 'irrigation', kjit, irrigation, nbpt, index)
+       !
+       CALL histwrite(hist_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
+       !
+    ELSE
+       !
+       CALL histwrite(hist_id, 'dis', kjit, hydrographs, nbpt, index)
+       !
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          !
+          CALL histwrite(hist2_id, 'riversret', kjit, returnflow, nbpt, index)
+          CALL histwrite(hist2_id, 'hydrographs', kjit, hydrographs, nbpt, index)
+          !
+          CALL histwrite(hist2_id, 'fastr', kjit, fast_diag, nbpt, index)
+          CALL histwrite(hist2_id, 'slowr', kjit, slow_diag, nbpt, index)
+          CALL histwrite(hist2_id, 'streamr', kjit, stream_diag, nbpt, index)
+          CALL histwrite(hist2_id, 'lakevol', kjit, lake_diag, nbpt, index)
+          !
+          CALL histwrite(hist2_id, 'irrigation', kjit, irrigation, nbpt, index)
+          !
+          CALL histwrite(hist2_id, 'netirrig', kjit, irrig_netereq, nbpt, index)
+          !
+       ELSE
+          !
+          CALL histwrite(hist2_id, 'dis', kjit, hydrographs, nbpt, index)
+          !
+       ENDIF
+    ENDIF
+    !
+    !
+  END SUBROUTINE routing_main
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_init(kjit, nbpt, index, dtradia, returnflow, irrigation, &
+       &                  riverflow, coastalflow, stempdiag, rest_id)
+    !
+    IMPLICIT NONE
+    !
+    ! interface description
+    ! input
+    !
+    INTEGER(i_std), INTENT(in)                     :: kjit          !! Time step number
+    INTEGER(i_std), INTENT(in)                     :: nbpt          !! Domain size  
+    INTEGER(i_std), DIMENSION (nbpt), INTENT(in)   :: index         !! Indeces of the points on the map
+    REAL(r_std), INTENT(in)                        :: dtradia       !! timestep
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)     :: returnflow     !! The water flow which returns to the grid box (kg/m^2 per dt)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)     :: irrigation     !! Irrigation flow (kg/m^2 per dt)
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)     :: riverflow      !! Outflow of the major rivers
+    REAL(r_std), DIMENSION (nbpt),INTENT(out)     :: coastalflow    !! Outflow on coastal points by small basins 
+    REAL(r_std), DIMENSION(nbpt,nbdl),INTENT(in)  :: stempdiag      !! Temperature profile in soil
+    INTEGER(i_std), INTENT(in)                     :: rest_id       !! Restart file identifier
+    !
+    ! local declaration   
+    !
+    CHARACTER(LEN=80)                             :: var_name         !! To store variables names for I/O
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)       :: tmp_real_g         !! A temporary real array for the integers
+    REAL(r_std), DIMENSION(1)     :: tmp_day
+    REAL(r_std)                   :: ratio, totarea
+    INTEGER(i_std)                :: ier, ig, ib, ipn(1)
+    !
+    ! These variables will require the configuration infrastructure
+    !
+    !Config Key  = ROUTING_TIMESTEP
+    !Config If   = RIVER_ROUTING
+    !Config Desc = Time step of th routing scheme
+    !Config Def  = one_day
+    !Config Help = This values gives the time step in seconds of the routing scheme. 
+    !Config        It should be multiple of the main time step of ORCHIDEE. One day
+    !Config        is a good value.
+    !
+    dt_routing = one_day
+    CALL getin_p('ROUTING_TIMESTEP', dt_routing)
+    !
+    !Config Key  = ROUTING_RIVERS
+    !Config If   = RIVER_ROUTING
+    !Config Desc = Number of rivers 
+    !Config Def  = 50
+    !Config Help = This parameter chooses the number of largest river basins
+    !Config        which should be treated as independently as rivers and not
+    !Config        flow into the oceans as diffusion coastal flow.
+    num_largest = 50
+    CALL getin_p('ROUTING_RIVERS', num_largest)
+    !
+    !Config Key  = DO_IRRIGATION
+    !Config Desc = Should we compute an irrigation flux 
+    !Config Def  = FALSE
+    !Config Help = This parameters allows the user to ask the model
+    !Config        to compute an irigation flux. This performed for the
+    !Config        on very simple hypothesis. The idea is to have a good
+    !Config        map of irrigated areas and a simple function which estimates
+    !Config        the need to irrigate.
+    !
+    doirrigation = .FALSE.
+    CALL getin_p('DO_IRRIGATION', doirrigation)
+    !
+    !Config Key  = DO_FLOODPLAINS
+    !Config Desc = Should we include floodplains 
+    !Config Def  = FALSE
+    !Config Help = This parameters allows the user to ask the model
+    !Config        to take into account the flood plains and return 
+    !Config        the water into the soil moisture. It then can go 
+    !Config        back to the atmopshere. This tried to simulate 
+    !Config        internal deltas of rivers.
+    !
+    dofloodplains = .FALSE.
+    CALL getin_p('DO_FLOODPLAINS', dofloodplains)
+    !
+    !
+    ! In order to simplify the time cascade check that dt_routing
+    ! is a multiple of dtradia
+    !
+    ratio = dt_routing/dtradia
+    IF ( ABS(NINT(ratio) - ratio) .GT. 10*EPSILON(ratio)) THEN
+       WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
+       WRITE(numout,*) "The chosen time step for the routing is not a multiple of the"
+       WRITE(numout,*) "main time step of the model. We will change dt_routing so that"
+       WRITE(numout,*) "this condition os fulfilled"
+       dt_routing = NINT(ratio) * dtradia
+       WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
+    ENDIF
+    !
+    IF ( dt_routing .LT. dtradia) THEN
+       WRITE(numout,*) 'WARNING -- WARNING -- WARNING -- WARNING'
+       WRITE(numout,*) 'The routing timestep can not be smaller than the one'
+       WRITE(numout,*) 'of the model. We reset its value to the model''s timestep.'
+       dt_routing = dtradia
+       WRITE(numout,*) 'THE NEW DT_ROUTING IS : ', dt_routing
+    ENDIF
+    !
+    var_name ="routingcounter"
+    IF (is_root_prc) THEN
+       CALL ioconf_setatt('UNITS', 's')
+       CALL ioconf_setatt('LONG_NAME','Time counter for the routing scheme')
+       CALL restget (rest_id, var_name, 1, 1, 1, kjit, .TRUE., tmp_day)
+       time_counter = tmp_day(1) 
+       CALL setvar (time_counter, val_exp, 'NO_KEYWORD', zero)
+    ENDIF
+    CALL bcast(time_counter)
+!!$    CALL setvar_p (time_counter, val_exp, 'NO_KEYWORD', zero)
+
+    !
+    ALLOCATE (routing_area_loc(nbpt,nbasmax))
+    ALLOCATE (routing_area_glo(nbp_glo,nbasmax))
+    var_name = 'routingarea'
+    IF (is_root_prc) THEN
+       CALL ioconf_setatt('UNITS', 'm^2')
+       CALL ioconf_setatt('LONG_NAME','Area of basin')
+       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., routing_area_glo, "gather", nbp_glo, index_g)
+    ENDIF
+    CALL scatter(routing_area_glo,routing_area_loc)
+    routing_area=>routing_area_loc
+    !
+    ALLOCATE (tmp_real_g(nbp_glo,nbasmax))
+    !
+    ALLOCATE (route_togrid_loc(nbpt,nbasmax))
+    ALLOCATE (route_togrid_glo(nbp_glo,nbasmax))      ! used in global in routing_flow
+    IF (is_root_prc) THEN
+       var_name = 'routetogrid'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Grid into which the basin flows')
+       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
+       route_togrid_glo(:,:) = undef_int
+       WHERE ( tmp_real_g .LT. val_exp )
+          route_togrid_glo = NINT(tmp_real_g)
+    ENDWHERE
+    ENDIF
+    CALL bcast(route_togrid_glo)                      ! used in global in routing_flow
+    CALL scatter(route_togrid_glo,route_togrid_loc)
+    route_togrid=>route_togrid_loc
+    !
+    ALLOCATE (route_tobasin_loc(nbpt,nbasmax))
+    ALLOCATE (route_tobasin_glo(nbp_glo,nbasmax))
+    IF (is_root_prc) THEN
+       var_name = 'routetobasin'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Basin in to which the water goes')
+       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
+       route_tobasin_glo = undef_int
+       WHERE ( tmp_real_g .LT. val_exp )
+         route_tobasin_glo = NINT(tmp_real_g)
+      ENDWHERE
+    ENDIF
+    CALL scatter(route_tobasin_glo,route_tobasin_loc)
+    route_tobasin=>route_tobasin_loc
+    !
+    ALLOCATE (global_basinid_loc(nbpt,nbasmax))
+    ALLOCATE (global_basinid_glo(nbp_glo,nbasmax))
+    IF (is_root_prc) THEN
+       var_name = 'basinid'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','ID of basin')
+       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., tmp_real_g, "gather", nbp_glo, index_g)
+       global_basinid_glo = undef_int
+       WHERE ( tmp_real_g .LT. val_exp )
+          global_basinid_glo = NINT(tmp_real_g)
+       ENDWHERE
+    ENDIF
+    CALL scatter(global_basinid_glo,global_basinid_loc)
+    global_basinid=>global_basinid_loc
+    !
+    ALLOCATE (topo_resid_loc(nbpt,nbasmax))
+    ALLOCATE (topo_resid_glo(nbp_glo,nbasmax))
+    IF (is_root_prc) THEN
+       var_name = 'topoindex'
+       CALL ioconf_setatt('UNITS', 'm')
+       CALL ioconf_setatt('LONG_NAME','Topographic index of the residence time')
+       CALL restget (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., topo_resid_glo, "gather", nbp_glo, index_g)
+    ENDIF
+    CALL scatter(topo_resid_glo,topo_resid_loc)
+    topo_resid=>topo_resid_loc
+    !
+    ALLOCATE (fast_reservoir(nbpt,nbasmax))
+    var_name = 'fastres'
+    CALL ioconf_setatt('UNITS', 'Kg')
+    CALL ioconf_setatt('LONG_NAME','Water in the fast reservoir')
+    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., fast_reservoir, "gather", nbp_glo, index_g)
+    CALL setvar_p (fast_reservoir, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (slow_reservoir(nbpt,nbasmax))
+    var_name = 'slowres'
+    CALL ioconf_setatt('UNITS', 'Kg')
+    CALL ioconf_setatt('LONG_NAME','Water in the slow reservoir')
+    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., slow_reservoir, "gather", nbp_glo, index_g)
+    CALL setvar_p (slow_reservoir, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (stream_reservoir(nbpt,nbasmax))
+    var_name = 'streamres'
+    CALL ioconf_setatt('UNITS', 'Kg')
+    CALL ioconf_setatt('LONG_NAME','Water in the stream reservoir')
+    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax, 1, kjit, .TRUE., stream_reservoir, "gather", nbp_glo, index_g)
+    CALL setvar_p (stream_reservoir, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (lake_reservoir(nbpt))
+    var_name = 'lakeres'
+    CALL ioconf_setatt('UNITS', 'Kg')
+    CALL ioconf_setatt('LONG_NAME','Water in the lake reservoir')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lake_reservoir, "gather", nbp_glo, index_g)
+    CALL setvar (lake_reservoir, val_exp, 'NO_KEYWORD', zero)
+    !
+    ! Map of irrigated areas
+    !
+    IF ( doirrigation ) THEN
+       ALLOCATE (irrigated(nbpt))
+       var_name = 'irrigated'
+       CALL ioconf_setatt('UNITS', 'm^2')
+       CALL ioconf_setatt('LONG_NAME','Surface of irrigated area')
+       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigated, "gather", nbp_glo, index_g)
+       CALL setvar_p (irrigated, val_exp, 'NO_KEYWORD', undef_sechiba)
+    ENDIF
+    !
+    ALLOCATE (previous_outflow(nbpt, nbasmax+3))
+    var_name = 'previous_outflow'
+    CALL ioconf_setatt('UNITS', 'm^3/dt')
+    CALL ioconf_setatt('LONG_NAME','Previous outflow from this basin')
+    CALL restget_p (rest_id, var_name, nbp_glo, nbasmax+3, 1, kjit, .TRUE., previous_outflow, "gather", nbp_glo, index_g)
+    CALL setvar_p (previous_outflow, val_exp, 'NO_KEYWORD', zero)
+    !
+    IF ( dofloodplains ) THEN
+       ALLOCATE (floodplains(nbpt))
+       var_name = 'floodplains'
+       CALL ioconf_setatt('UNITS', 'm^2')
+       CALL ioconf_setatt('LONG_NAME','Surface which can be flooded')
+       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., floodplains, "gather", nbp_glo, index_g)
+       CALL setvar_p (floodplains, val_exp, 'NO_KEYWORD', undef_sechiba)
+    ENDIF
+    !
+    ! Put into the restart file the fluxes so that they can be regenerated at restart.
+    !
+    ALLOCATE (lakeinflow_mean(nbpt))
+    var_name = 'lakeinflow'
+    CALL ioconf_setatt('UNITS', 'Kg/dt')
+    CALL ioconf_setatt('LONG_NAME','Lake inflow')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., lakeinflow_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (lakeinflow_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE (returnflow_mean(nbpt))
+    var_name = 'returnflow'
+    CALL ioconf_setatt('UNITS', 'Kg/m^2/dt')
+    CALL ioconf_setatt('LONG_NAME','Deep return flux')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., returnflow_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (returnflow_mean, val_exp, 'NO_KEYWORD', zero)
+    returnflow(:) = returnflow_mean(:)
+    !
+    ALLOCATE (irrigation_mean(nbpt))
+    ALLOCATE (irrig_netereq(nbpt))
+    irrig_netereq(:) = zero
+    !
+    IF ( doirrigation ) THEN
+       var_name = 'irrigation'
+       CALL ioconf_setatt('UNITS', 'Kg/dt')
+       CALL ioconf_setatt('LONG_NAME','Artificial irrigation flux')
+       CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., irrigation_mean, "gather", nbp_glo, index_g)
+       CALL setvar_p (irrigation_mean, val_exp, 'NO_KEYWORD', zero)
+    ELSE
+       irrigation_mean(:) = zero
+    ENDIF
+    irrigation(:) = irrigation_mean(:) 
+    !
+    ALLOCATE (riverflow_mean(nbpt))
+    var_name = 'riverflow'
+    CALL ioconf_setatt('UNITS', 'Kg/dt')
+    CALL ioconf_setatt('LONG_NAME','River flux into the sea')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., riverflow_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (riverflow_mean, val_exp, 'NO_KEYWORD', zero)
+    riverflow(:) = riverflow_mean(:)
+    !
+    ALLOCATE (coastalflow_mean(nbpt))
+    var_name = 'coastalflow'
+    CALL ioconf_setatt('UNITS', 'Kg/dt')
+    CALL ioconf_setatt('LONG_NAME','Diffuse flux into the sea')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., coastalflow_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (coastalflow_mean, val_exp, 'NO_KEYWORD', zero)
+    coastalflow(:) = coastalflow_mean(:)
+    !
+    ! Locate it at the 2m level
+    ipn = MINLOC(ABS(diaglev-2))
+    floodtemp_lev = ipn(1)
+    ALLOCATE (floodtemp(nbpt))
+    floodtemp(:) = stempdiag(:,floodtemp_lev)
+    !
+    ALLOCATE(hydrographs(nbpt))
+    var_name = 'hydrographs'
+    CALL ioconf_setatt('UNITS', 'm^3/dt')
+    CALL ioconf_setatt('LONG_NAME','Hydrograph at outlow of grid')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., hydrographs, "gather", nbp_glo, index_g)
+    CALL setvar_p (hydrographs, val_exp, 'NO_KEYWORD', zero)
+    !
+    ! The diagnostic variables, they are initialized from the above restart variables.
+    !
+    ALLOCATE(fast_diag(nbpt), slow_diag(nbpt), stream_diag(nbpt), lake_diag(nbpt), stat=ier)
+    !
+    fast_diag(:) = zero
+    slow_diag(:) = zero
+    stream_diag(:) = zero
+    lake_diag(:) = zero
+    !
+    DO ig=1,nbpt
+       totarea = zero
+       DO ib=1,nbasmax
+          totarea = totarea + routing_area(ig,ib)
+          fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
+          slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
+          stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
+       ENDDO
+       !
+       fast_diag(ig) = fast_diag(ig)/totarea
+       slow_diag(ig) = slow_diag(ig)/totarea
+       stream_diag(ig) = stream_diag(ig)/totarea
+       !
+       ! This is the volume of the lake scaled to the entire grid.
+       ! It would be batter to scale it to the size of the lake
+       ! but this information is not yet available.
+       !
+       lake_diag(ig) = lake_reservoir(ig)/totarea
+       !
+    ENDDO
+    !
+    !
+    ! Get from the restart the fluxes we accumulated.
+    !
+    ALLOCATE (runoff_mean(nbpt))
+    var_name = 'runoff_route'
+    CALL ioconf_setatt('UNITS', 'Kg')
+    CALL ioconf_setatt('LONG_NAME','Accumulated runoff for routing')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (runoff_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE(drainage_mean(nbpt))
+    var_name = 'drainage_route'
+    CALL ioconf_setatt('UNITS', 'Kg')
+    CALL ioconf_setatt('LONG_NAME','Accumulated drainage for routing')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (drainage_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE(evapot_mean(nbpt))
+    var_name = 'evapot_route'
+    CALL ioconf_setatt('UNITS', 'Kg/m^2')
+    CALL ioconf_setatt('LONG_NAME','Accumulated potential evaporation for routing')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., evapot_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (evapot_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE(precip_mean(nbpt))
+    var_name = 'precip_route'
+    CALL ioconf_setatt('UNITS', 'Kg/m^2')
+    CALL ioconf_setatt('LONG_NAME','Accumulated rain precipitation for irrigation')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., precip_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (precip_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE(humrel_mean(nbpt))
+    var_name = 'humrel_route'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Mean humrel for irrigation')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., humrel_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (humrel_mean, val_exp, 'NO_KEYWORD', un)
+    !
+    ALLOCATE(totnobio_mean(nbpt))
+    var_name = 'totnobio_route'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Last Total fraction of no bio for irrigation')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., totnobio_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (totnobio_mean, val_exp, 'NO_KEYWORD', zero)
+    !
+    ALLOCATE(vegtot_mean(nbpt))
+    var_name = 'vegtot_route'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Last Total fraction of vegetation')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., vegtot_mean, "gather", nbp_glo, index_g)
+    CALL setvar_p (vegtot_mean, val_exp, 'NO_KEYWORD', un)
+    !
+    !
+    DEALLOCATE(tmp_real_g)
+    !
+    ! Allocate diagnostic variables
+    !
+    ALLOCATE(hydrodiag_loc(nbpt,nbasmax),hydrodiag_glo(nbp_glo,nbasmax),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in hydrodiag allocation. We stop. We need kjpindex words = ', nbpt*nbasmax
+        STOP 'routing_init'
+    END IF
+
+    hydrodiag=>hydrodiag_loc
+    !
+    !
+  END SUBROUTINE routing_init
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_clear()
+    !
+    l_first_routing=.TRUE.
+    !
+    IF (ALLOCATED(routing_area_loc)) DEALLOCATE(routing_area_loc)
+    IF (ALLOCATED(route_togrid_loc)) DEALLOCATE(route_togrid_loc)
+    IF (ALLOCATED(route_tobasin_loc)) DEALLOCATE(route_tobasin_loc)
+    IF (ALLOCATED(global_basinid_loc)) DEALLOCATE(global_basinid_loc)
+    IF (ALLOCATED(topo_resid_loc)) DEALLOCATE(topo_resid_loc)
+    IF (ALLOCATED(routing_area_glo)) DEALLOCATE(routing_area_glo)
+    IF (ALLOCATED(route_togrid_glo)) DEALLOCATE(route_togrid_glo)
+    IF (ALLOCATED(route_tobasin_glo)) DEALLOCATE(route_tobasin_glo)
+    IF (ALLOCATED(global_basinid_glo)) DEALLOCATE(global_basinid_glo)
+    IF (ALLOCATED(topo_resid_glo)) DEALLOCATE(topo_resid_glo)
+    IF (ALLOCATED(fast_reservoir)) DEALLOCATE(fast_reservoir)
+    IF (ALLOCATED(slow_reservoir)) DEALLOCATE(slow_reservoir)
+    IF (ALLOCATED(stream_reservoir)) DEALLOCATE(stream_reservoir)
+    IF (ALLOCATED(lake_reservoir)) DEALLOCATE(lake_reservoir)
+    IF (ALLOCATED(returnflow_mean)) DEALLOCATE(returnflow_mean)
+    IF (ALLOCATED(riverflow_mean)) DEALLOCATE(riverflow_mean)
+    IF (ALLOCATED(coastalflow_mean)) DEALLOCATE(coastalflow_mean)
+    IF (ALLOCATED(lakeinflow_mean)) DEALLOCATE(lakeinflow_mean)
+    IF (ALLOCATED(runoff_mean)) DEALLOCATE(runoff_mean)
+    IF (ALLOCATED(drainage_mean)) DEALLOCATE(drainage_mean)
+    IF (ALLOCATED(evapot_mean)) DEALLOCATE(evapot_mean)
+    IF (ALLOCATED(precip_mean)) DEALLOCATE(precip_mean)
+    IF (ALLOCATED(humrel_mean)) DEALLOCATE(humrel_mean)
+    IF (ALLOCATED(totnobio_mean)) DEALLOCATE(totnobio_mean)
+    IF (ALLOCATED(vegtot_mean)) DEALLOCATE(vegtot_mean)
+    IF (ALLOCATED(floodtemp)) DEALLOCATE(floodtemp)
+    IF (ALLOCATED(hydrodiag_loc)) DEALLOCATE(hydrodiag_loc)
+    IF (ALLOCATED(hydrodiag_glo)) DEALLOCATE(hydrodiag_glo)
+    IF (ALLOCATED(hydrographs)) DEALLOCATE(hydrographs)
+    IF (ALLOCATED(irrigation_mean)) DEALLOCATE(irrigation_mean)
+    IF (ALLOCATED(irrigated)) DEALLOCATE(irrigated)
+    IF (ALLOCATED(floodplains)) DEALLOCATE(floodplains)
+    !
+  END SUBROUTINE routing_clear
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_flow(nbpt, dt_routing, runoff, drainage, &
+       &                  vegtot, totnobio, evapot, precip, humrel, floodtemp, &
+       &                  lakeinflow, returnflow, irrigation, riverflow, &
+       &                  coastalflow, hydrographs)
+    !
+    IMPLICIT NONE
+    !
+    !
+    !  INPUT
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                !! Domain size
+    REAL(r_std), INTENT (in)      :: dt_routing          !! Time step in seconds
+    REAL(r_std), INTENT(in)       :: runoff(nbpt)        !! grid-point runoff
+    REAL(r_std), INTENT(in)       :: drainage(nbpt)      !! grid-point drainage
+    REAL(r_std), INTENT(in)       :: vegtot(nbpt)        !! Potentially vegetated area
+    REAL(r_std), INTENT(in)       :: totnobio(nbpt)      !! Other areas whichcan not have vegetation
+    REAL(r_std), INTENT(in)       :: evapot(nbpt)        !! grid-point potential evaporation
+    REAL(r_std), INTENT(in)       :: precip(nbpt)        !! Precipiation (rainfall here)
+    REAL(r_std), INTENT(in)       :: humrel(nbpt)        !! Soil moisture stress
+    REAL(r_std), INTENT(in)       :: floodtemp(nbpt)     !! Temperature to decide if floodplains work
+    REAL(r_std), INTENT(out)      :: lakeinflow(nbpt)    !! The water flow which flows into lakes (kg/dt)
+    REAL(r_std), INTENT(out)      :: returnflow(nbpt)    !! Water flowing back into soil moisture (kg/m^2/dt)
+    REAL(r_std), INTENT(out)      :: irrigation(nbpt)    !! The artificial irrigation (kg/m^2 per dt) 
+    REAL(r_std), INTENT(out)      :: riverflow(nbpt)     !! Outflow of the major rivers (kg/dt)
+    REAL(r_std), INTENT(out)      :: coastalflow(nbpt)   !! Outflow on coastal points by small basins (kg/dt) 
+    REAL(r_std), INTENT(out)      :: hydrographs(nbpt)   !! Hydrographs at the outflow of the gird box for major basins   
+    !
+    ! LOCAL
+    !
+    REAL(r_std), DIMENSION(nbpt, nbasmax)   :: fast_flow
+    REAL(r_std), DIMENSION(nbpt, nbasmax)   :: slow_flow
+    REAL(r_std), DIMENSION(nbpt, nbasmax)   :: stream_flow
+    REAL(r_std), DIMENSION(nbpt, nbasmax)   :: reinfiltration
+    REAL(r_std), DIMENSION(nbpt, nbasmax)   :: baseirrig      !! Irrigation uptake from each basin reservoir.
+    REAL(r_std), DIMENSION(nbpt, 0:nbasmax+3) :: transport
+    REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_glo
+    REAL(r_std), DIMENSION(nbp_glo, 0:nbasmax+3) :: transport_sum
+    REAL(r_std), DIMENSION(nbpt, nbasmax)   :: floods, wdelay, previous_outflow, potflood, inflow
+    REAL(r_std), DIMENSION(nbpt)            :: tobeflooded
+    REAL(r_std), DIMENSION(nbpt)            :: totarea
+    REAL(r_std)                             :: flow, floodindex
+    INTEGER(i_std) :: ig, ib, rtg, rtb, ierr
+
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)   :: fast_flow_g,slow_flow_g,stream_flow_g,floods_g,wdelay_g
+
+    !
+    transport(:,:) = zero
+    transport_glo(:,:) = zero
+    previous_outflow(:,:) = zero
+    irrig_netereq(:) = zero
+    baseirrig(:,:) = zero
+    totarea(:) = zero
+    !
+    ! Compute all the fluxes
+    !
+    DO ig=1,nbpt
+       DO ib=1,nbasmax
+          !
+          totarea(ig) = totarea(ig) + routing_area(ig,ib)
+          !
+          IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
+             !
+             flow = MIN(fast_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*fast_tcst*one_day/dt_routing),&
+                  & fast_reservoir(ig,ib))
+             fast_flow(ig,ib) = flow
+             !
+             flow = MIN(slow_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*slow_tcst*one_day/dt_routing),&
+                  & slow_reservoir(ig,ib))
+             slow_flow(ig,ib) = flow
+             !
+             flow = MIN(stream_reservoir(ig,ib)/((topo_resid(ig,ib)/1000.)*stream_tcst*one_day/dt_routing),&
+                  & stream_reservoir(ig,ib))
+             stream_flow(ig,ib) = flow
+             ! 
+             !
+          ELSE
+             fast_flow(ig,ib) = zero
+             slow_flow(ig,ib) = zero
+             stream_flow(ig,ib) = zero
+          ENDIF
+          inflow(ig,ib) = fast_flow(ig,ib) + slow_flow(ig,ib) + stream_flow(ig,ib)
+       ENDDO
+    ENDDO
+    !
+    ! Do the floodings
+    !
+    IF ( dofloodplains ) THEN
+       DO ig=1,nbpt
+          tobeflooded(ig) = floodplains(ig)
+          DO ib=1,nbasmax
+             potflood(ig,ib) = inflow(ig,ib) - previous_outflow(ig,ib)
+             !
+             IF ( tobeflooded(ig) > 0. .AND. potflood(ig,ib) > zero .AND. floodtemp(ig) > tp_00 ) THEN
+                !
+                IF (routing_area(ig,ib) > tobeflooded(ig)) THEN
+                   floodindex = tobeflooded(ig) / routing_area(ig,ib)
+                   ELSE
+                      floodindex = un
+                ENDIF
+                !
+                floods(ig,ib) = floodindex * evap_cst * potflood(ig,ib)
+                !
+                wdelay(ig,ib) = floodindex * wdelay_cst * potflood(ig,ib)
+                !
+                !
+                tobeflooded(ig) = tobeflooded(ig) - routing_area(ig,ib) 
+                !
+                ELSE
+                   floods(ig,ib) = zero
+                   wdelay(ig,ib) = zero
+             ENDIF
+          ENDDO
+       ENDDO
+    ELSE
+       DO ig=1,nbpt
+          DO ib=1,nbasmax
+             floods(ig,ib) = zero
+             wdelay(ig,ib) = zero
+          ENDDO
+       ENDDO
+    ENDIF
+    !
+    DO ig=1,nbpt
+       DO ib=1,nbasmax
+        reinfiltration(ig,ib) = floods(ig,ib)    
+      ENDDO
+    ENDDO
+
+!ym cette methode conserve les erreurs d'arrondie
+!ym mais n'est pas la plus efficace
+
+    IF (is_root_prc) &
+         ALLOCATE( fast_flow_g(nbp_glo, nbasmax), slow_flow_g(nbp_glo, nbasmax), &
+          stream_flow_g(nbp_glo, nbasmax), floods_g(nbp_glo, nbasmax), wdelay_g(nbp_glo, nbasmax) )
+    
+       
+    CALL gather(fast_flow,fast_flow_g)
+    CALL gather(slow_flow,slow_flow_g)
+    CALL gather(stream_flow,stream_flow_g)
+    CALL gather(floods,floods_g)
+    CALL gather(wdelay,wdelay_g)
+
+    IF (is_root_prc) THEN
+       DO ig=1,nbp_glo
+          DO ib=1,nbasmax
+             !
+             rtg = route_togrid_glo(ig,ib)
+             rtb = route_tobasin_glo(ig,ib)
+             transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow_g(ig,ib) + slow_flow_g(ig,ib) + &
+                  & stream_flow_g(ig,ib) - floods_g(ig,ib) - wdelay_g(ig,ib)
+             !
+          ENDDO
+       ENDDO
+    ENDIF
+
+    IF (is_root_prc) &
+         DEALLOCATE( fast_flow_g, slow_flow_g, stream_flow_g, floods_g, wdelay_g )
+   
+    CALL scatter(transport_glo,transport)
+
+!ym    DO ig=1,nbpt
+!ym       DO ib=1,nbasmax
+!ym          !
+!ym          rtg = route_togrid(ig,ib)
+!ym          rtb = route_tobasin(ig,ib)
+!ym          transport_glo(rtg,rtb) = transport_glo(rtg,rtb) + fast_flow(ig,ib) + slow_flow(ig,ib) + &
+!ym               & stream_flow(ig,ib) - floods(ig,ib) - wdelay(ig,ib)
+!ym          !
+!ym       ENDDO
+!ym    ENDDO
+!ym    
+!ym    CALL reduce_sum(transport_glo,transport_sum)
+!ym    CALL scatter(transport_sum,transport)
+    
+    !
+    ! Update all reservoirs
+    !
+    DO ig=1,nbpt
+       DO ib=1,nbasmax
+          fast_reservoir(ig,ib) =  fast_reservoir(ig,ib) + runoff(ig)*routing_area(ig,ib) - &
+               & reinfiltration(ig,ib) - fast_flow(ig,ib) + floods(ig,ib) + wdelay(ig,ib)
+          slow_reservoir(ig,ib) = slow_reservoir(ig,ib) + drainage(ig)*routing_area(ig,ib) - &
+               & slow_flow(ig,ib)
+          stream_reservoir(ig,ib) = stream_reservoir(ig,ib) + transport(ig,ib) - &
+               & stream_flow(ig,ib)
+          !
+          previous_outflow(ig,ib) = fast_flow(ig,ib) + slow_flow(ig,ib) + stream_flow(ig,ib) - & 
+               &  wdelay(ig,ib) - floods(ig,ib)
+          !
+       ENDDO
+    ENDDO
+    !
+    ! Compute the total reinfiltration in the grid box
+    !
+    returnflow(:) = zero
+    DO ig=1,nbpt
+       !
+       DO ib=1,nbasmax
+          returnflow(ig) =  returnflow(ig) + reinfiltration(ig,ib)
+       ENDDO
+       !
+       returnflow(ig) = returnflow(ig)/totarea(ig)
+       !
+    ENDDO
+    !
+    ! Compute the net irrigation requirement from Univ of Kassel
+    !
+    ! This is a very low priority process and thus only applies if
+    ! there is some water left in the reservoirs after all other things.
+    !
+    IF ( doirrigation ) THEN
+       DO ig=1,nbpt
+          
+          IF ((vegtot(ig) .GT. zero) .AND. (humrel(ig) .LT. 0.99)) THEN
+             irrig_netereq(ig) = (irrigated(ig) / totarea(ig) ) * MAX(zero, &
+                  & crop_coef * evapot(ig) - &
+                  & MAX(precip(ig)+returnflow(ig)-runoff(ig)-drainage(ig), zero) )
+             irrig_netereq(ig) = 1 * irrig_netereq(ig)
+             
+             IF(irrig_netereq(ig).LT.zero) THEN
+                WRITE(numout,*) 'there is a probleme for irrig_netereq',ig,irrig_netereq(ig)
+             ENDIF
+             
+          ENDIF
+
+          DO ib=1,nbasmax
+             IF ( route_tobasin(ig,ib) .GT. 0 ) THEN
+
+                baseirrig(ig,ib) = MIN( irrig_netereq(ig) * routing_area(ig,ib),&
+                     &   stream_reservoir(ig,ib) + fast_reservoir(ig,ib) + slow_reservoir(ig,ib) )
+                
+                slow_reservoir(ig,ib) = MAX(zero, slow_reservoir(ig,ib) + &
+                     & MIN(zero, fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-baseirrig(ig,ib))))
+
+                fast_reservoir(ig,ib) = MAX( zero, &
+                     &  fast_reservoir(ig,ib) + MIN(zero, stream_reservoir(ig,ib)-baseirrig(ig,ib)))
+                stream_reservoir(ig,ib) = MAX(zero, stream_reservoir(ig,ib)-baseirrig(ig,ib) )
+
+                IF(baseirrig(ig,ib) .LT. zero .OR. slow_reservoir(ig,ib) .LT. zero .OR. &
+                     & fast_reservoir(ig,ib) .LT. zero .OR. stream_reservoir(ig,ib) .LT. zero) THEN
+                   WRITE(numout,*) 'There is negative values related to irrigation', ig,ib,baseirrig(ig,ib), &
+                        & slow_reservoir(ig,ib),fast_reservoir(ig,ib),stream_reservoir(ig,ib)
+                ENDIF
+
+             ENDIF
+             
+             previous_outflow(ig,ib) = fast_flow(ig,ib) + slow_flow(ig,ib) + stream_flow(ig,ib) - &
+                  &  wdelay(ig,ib) - floods(ig,ib)
+             
+          ENDDO
+       ENDDO
+       !
+    ENDIF
+    !
+    !
+    ! Compute the fluxes which leave the routing scheme
+    !
+    ! Lakeinflow is in Kg/dt
+    ! returnflow is in Kg/m^2/dt
+    !
+    hydrographs(:) = zero
+    fast_diag(:) = zero
+    slow_diag(:) = zero
+    stream_diag(:) = zero
+    irrigation(:) = zero
+    !
+    !
+    DO ig=1,nbpt
+       !
+       DO ib=1,nbasmax
+          IF (hydrodiag(ig,ib) > 0 ) THEN
+             hydrographs(ig) = hydrographs(ig) + fast_flow(ig,ib) + slow_flow(ig,ib) + & 
+           &  stream_flow(ig,ib) - floods(ig,ib) - wdelay(ig,ib) 
+          ENDIF
+          fast_diag(ig) = fast_diag(ig) + fast_reservoir(ig,ib)
+          slow_diag(ig) = slow_diag(ig) + slow_reservoir(ig,ib)
+          stream_diag(ig) = stream_diag(ig) + stream_reservoir(ig,ib)
+          irrigation (ig) = irrigation (ig) + baseirrig(ig,ib)
+       ENDDO
+       !
+       fast_diag(ig) = fast_diag(ig)/totarea(ig)
+       slow_diag(ig) = slow_diag(ig)/totarea(ig)
+       stream_diag(ig) = stream_diag(ig)/totarea(ig)
+       !
+       irrigation(ig) = irrigation(ig)/totarea(ig)
+       !
+       ! The three output types for the routing : endoheric basins,, rivers and 
+       ! diffuse coastal flow.
+       !
+       lakeinflow(ig) = transport(ig,nbasmax+1)
+       coastalflow(ig) = transport(ig,nbasmax+2)
+       riverflow(ig) = transport(ig,nbasmax+3)
+       !
+       IF ( irrigation(ig) .GE. irrig_netereq(ig)+1e4 ) THEN
+          WRITE(numout,*) 'There is a problem here with irrigation',ig,irrigation(ig),irrig_netereq(ig)
+          WRITE(numout,*) irrigated(ig),totarea(ig), evapot(ig), precip_mean(ig),runoff(ig),drainage(ig)
+          STOP
+       ENDIF
+       !
+    ENDDO
+    !
+  END SUBROUTINE routing_flow
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_lake(nbpt, dt_routing, lakeinflow, humrel, returnflow)
+    !
+    IMPLICIT NONE
+    !
+    ! This routine stores water in lakes so that it does not cycle through
+    ! the runoff. For the moment it only works for endoheric lakes but I can
+    ! be extended in the future.
+    ! The return flow to the soil moisture reservoir is based on a maximum
+    ! lake evaporation rate (maxevap_lake).
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                !! Domain size
+    REAL(r_std), INTENT (in)      :: dt_routing          !! Time step in seconds
+    REAL(r_std), INTENT(in)       :: lakeinflow(nbpt)    !! Flow into the lake (kg/dt)
+    REAL(r_std), INTENT(in)       :: humrel(nbpt)        !! Soil moisture deficit around the lake (Hum !)
+    REAL(r_std), INTENT(out)      :: returnflow(nbpt)    !! Water flowing back into soil moisture (kg/m^2/dt)
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std)                :: ig
+    REAL(r_std)                   :: refill, total_area
+    !
+    !
+    !
+    DO ig=1,nbpt
+       !
+       total_area = SUM(routing_area(ig,:))
+       !
+       lake_reservoir(ig) = lake_reservoir(ig) + lakeinflow(ig)
+       !uptake in Kg/dt
+       refill = MAX(zero, maxevap_lake * (un - humrel(ig)) * dt_routing * total_area)
+       returnflow(ig) = MIN(refill, lake_reservoir(ig))
+       lake_reservoir(ig) = lake_reservoir(ig) - returnflow(ig)
+       !Return in Kg/m^2/dt
+       returnflow(ig) = returnflow(ig)/total_area
+       !
+       ! This is the volume of the lake scaled to the entire grid.
+       ! It would be batter to scale it to the size of the lake
+       ! but this information is not yet available.
+       lake_diag(ig) = lake_reservoir(ig)/total_area
+       !
+    ENDDO
+    !
+  END SUBROUTINE routing_lake
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_diagnostic_p(nbpt,index, resolution, contfrac, hist_id, hist2_id)
+    !
+    IMPLICIT NONE
+    
+    INTEGER(i_std), INTENT(in)    :: nbpt                !! Domain size
+    INTEGER(i_std), INTENT(in)    :: index(nbpt)         !! Indeces of the points on the map 
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)  !! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)      !! Fraction of land in each grid box.
+    INTEGER(i_std),INTENT (in)    :: hist_id             !! _history_ file identifier  
+    INTEGER(i_std),INTENT (in)    :: hist2_id            !! _history_ file 2 identifier
+    REAL(r_std), DIMENSION(nbpt)        :: nbrivers    !! Number of rivers in the grid
+    REAL(r_std), DIMENSION(nbpt)        :: basinmap    !! Map of basins
+    REAL(r_std), DIMENSION(nbp_glo)        :: nbrivers_g    !! Number of rivers in the grid
+    REAL(r_std), DIMENSION(nbp_glo)        :: basinmap_g    !! Map of basins
+
+    routing_area => routing_area_glo  
+    topo_resid => topo_resid_glo
+    route_togrid => route_togrid_glo
+    route_tobasin => route_tobasin_glo
+    global_basinid => global_basinid_glo
+    hydrodiag=>hydrodiag_glo
+    
+    IF (is_root_prc) CALL routing_diagnostic(nbp_glo,index_g, resolution_g, contfrac_g, nbrivers_g,basinmap_g)
+
+    routing_area => routing_area_loc  
+    topo_resid => topo_resid_loc
+    route_togrid => route_togrid_loc
+    route_tobasin => route_tobasin_loc
+    global_basinid => global_basinid_loc
+    hydrodiag=>hydrodiag_loc
+    
+    CALL scatter(nbrivers_g,nbrivers)
+    CALL scatter(basinmap_g,basinmap)
+    CALL scatter(hydrodiag_glo,hydrodiag_loc)
+        
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite(hist_id, 'basinmap', 1, basinmap, nbpt, index)
+       CALL histwrite(hist_id, 'nbrivers', 1, nbrivers, nbpt, index)
+    ELSE
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite(hist2_id, 'basinmap', 1, basinmap, nbpt, index)
+          CALL histwrite(hist2_id, 'nbrivers', 1, nbrivers, nbpt, index)
+       ELSE
+       ENDIF
+    ENDIF
+    
+        
+  END SUBROUTINE routing_diagnostic_p
+
+
+  SUBROUTINE routing_diagnostic(nbpt,index, resolution, contfrac,nbrivers,basinmap)
+    !
+    ! This subroutine will set up a map of the major basins
+    !
+    !  INPUTS
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                !! Domain size
+    INTEGER(i_std), INTENT(in)    :: index(nbpt)         !! Indeces of the points on the map 
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)  !! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)      !! Fraction of land in each grid box.
+    !
+    !  OUTPUTS
+    !
+    REAL(r_std), DIMENSION(nbpt), INTENT(out)        :: nbrivers    !! Number of rivers in the grid
+    REAL(r_std), DIMENSION(nbpt), INTENT(out)        :: basinmap    !! Map of basins
+    !
+    !  LOCAL
+    !
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: pts         !! list the points belonging to the basin
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: ptbas       !! list the basin number for this point
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: outpt       !! Outflow point for each basin
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: nb_pts      !! Number of points in the basin
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)        :: totarea     !! Total area of basin
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: topids      !! The IDs of the first num_largest basins.
+    CHARACTER(LEN=25), ALLOCATABLE, DIMENSION(:) :: basin_names !! Names of the rivers
+    CHARACTER(LEN=25)                            :: name_str
+    !
+    INTEGER(i_std) :: ig, ib, og, ob, ign, ibn, ff(1), ic, icc, nb_small
+    !
+    ALLOCATE(pts(num_largest, nbpt))
+    ALLOCATE(ptbas(num_largest, nbpt))
+    ALLOCATE(outpt(num_largest, 2))
+    ALLOCATE(nb_pts(num_largest))
+    ALLOCATE(totarea(num_largest))
+    ALLOCATE(topids(num_largest))
+    !
+    !
+    ! First we get the list of all river outflow points
+    ! We work under the assumption that we only have num_largest basins finishing with
+    ! nbasmax+3. This is checked in routing_truncate.
+    !
+    nb_small = 1
+    outpt(:,:) = -1
+    ic = 0
+    DO ig=1,nbpt
+       DO ib=1,nbasmax
+          ign = route_togrid(ig, ib)
+          ibn = route_tobasin(ig, ib)
+          IF ( ibn .EQ. nbasmax+3) THEN
+             ic = ic + 1
+             outpt(ic,1) = ig
+             outpt(ic,2) = ib
+             !
+             ! Get the largest id of the basins we call a river. This is
+             ! to extract the names of all rivers.
+             !
+             IF ( global_basinid(ig,ib) > nb_small ) THEN
+                nb_small = global_basinid(ig,ib)
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    nb_small = MIN(nb_small, 349)
+    !
+    ALLOCATE(basin_names(nb_small))
+    !
+    CALL routing_names(nb_small, basin_names)
+    !
+    ! Go through all points and basins to see if they outflow as a river and store the
+    ! information needed in the various arrays.
+    !
+    nb_pts(:) = 0
+    totarea(:) = zero
+    hydrodiag(:,:) = 0
+    DO ig=1,nbpt
+       DO ib=1,nbasmax
+          ic = 0
+          ign = ig
+          ibn = ib
+          ! Locate outflow point
+          DO WHILE (ibn .GT. 0 .AND. ibn .LE. nbasmax .AND. ic .LT. nbasmax*nbpt)
+             ic = ic + 1
+             og = ign
+             ob = ibn
+             ign = route_togrid(og, ob)
+             ibn = route_tobasin(og, ob)
+          ENDDO
+          !
+          ! Now that we have an outflow check if it is one of the num_largest rivers. 
+          ! In this case we keeps the location so we diagnose it.
+          !
+          IF ( ibn .EQ. nbasmax + 3) THEN
+             DO icc = 1,num_largest
+                IF ( outpt(icc,1) .EQ. og .AND. outpt(icc,2) .EQ. ob ) THEN
+                   !
+                   ! We only keep this point for our map if it is large enough.
+                   !
+                   IF ( routing_area(ig,ib) .GT. 0.25*resolution(ig,1)*resolution(ig,2)*contfrac(ig) ) THEN
+                      nb_pts(icc) = nb_pts(icc) + 1
+                      pts(icc, nb_pts(icc)) = ig
+                      ptbas(icc, nb_pts(icc)) = ib
+                   ENDIF
+                   totarea(icc) = totarea(icc) + routing_area(ig,ib)
+                   ! ID of the river is taken from the last point before the outflow.
+                   topids(icc) = global_basinid(og,ob)
+                   !
+                   ! On this gridbox and basin we will diagnose the hydrograph
+                   !
+                   hydrodiag(ig, ib) = 1
+                   !
+                ENDIF
+             ENDDO
+          ENDIF
+
+       ENDDO
+    ENDDO
+    !
+    ! Construct the map of the largest basins. We take the num_largest basins
+    ! if they have more than 4 points. After that it is of no use.
+    !
+    !
+    basinmap(:) = zero
+    DO icc = 1, num_largest
+       ff = MAXLOC(totarea)   
+       IF ( nb_pts(ff(1)) .GT. 2 ) THEN
+          DO ig = 1, nb_pts(ff(1))
+             basinmap(pts(ff(1),ig)) = REAL(icc,r_std)
+          ENDDO
+          !
+          IF ( topids(ff(1)) .GT. nb_small ) THEN
+             WRITE(name_str, '("NN, Nb : ",I4)') topids(ff(1))
+          ELSE
+             name_str = basin_names(topids(ff(1)))
+          ENDIF
+          !
+          WRITE(numout,&
+               '("Basin ID ", I5," ", A15, " Area [km^2] : ", F13.4, " Nb points : ", I4)')&
+               & topids(ff(1)), name_str(1:15), totarea(ff(1))/1.e6,  nb_pts(ff(1))
+       ENDIF
+       totarea(ff(1)) = zero
+    ENDDO
+    !
+    !
+    nbrivers(:) = zero
+    DO ig=1,nbpt
+       nbrivers(ig) = COUNT(route_tobasin(ig,1:nbasmax) == nbasmax+3)
+    ENDDO
+    DO ig=1,nbpt
+       IF ( nbrivers(ig) > 1 ) THEN
+          WRITE(numout,*) 'Grid box ', ig, ' has ', NINT(nbrivers(ig)), ' outflow points.'
+          WRITE(numout,*) 'The rivers which flow into the ocean at this point are :'
+          DO icc=1,nbasmax
+             IF ( route_tobasin(ig,icc) == nbasmax+3) THEN
+                IF ( global_basinid(ig,icc) <= nb_small ) THEN
+                   WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Name = ', basin_names(global_basinid(ig,icc))
+                ELSE
+                   WRITE(numout,*) 'ID = ',global_basinid(ig,icc), ' Problem ===== ID is larger than possible'
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDIF
+    ENDDO
+    !
+    WRITE(numout,*) 'Maximum topographic index :', MAXVAL(topo_resid)
+    ic = COUNT(topo_resid .GT. 0.)
+    WRITE(numout,*) 'Mean topographic index :', SUM(topo_resid, MASK=topo_resid .GT. zero)/ic
+    WRITE(numout,*) 'Minimum topographic index :', MINVAL(topo_resid, MASK=topo_resid .GT. zero)
+    !
+    DEALLOCATE(pts)
+    DEALLOCATE(outpt)
+    DEALLOCATE(nb_pts)
+    DEALLOCATE(totarea)
+    !
+  END SUBROUTINE routing_diagnostic
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_basins_p(nbpt, lalo, neighbours, resolution, contfrac)
+    !
+    IMPLICIT NONE
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)        ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)    :: neighbours(nbpt,8)  ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)  ! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)     ! Fraction of land in each grid box.
+
+!    INTEGER(i_std)    :: neighbours_tmp(nbpt,8)
+    INTEGER(i_std) :: i,j
+    
+!    DO i=1,nbp_loc
+!      DO j=1,8
+!	IF (neighbours(i,j)==-1) THEN
+!	  neighbours_tmp(i,j)=neighbours(i,j)
+!	ELSE
+!	  neighbours_tmp(i,j)=neighbours(i,j)+nbp_para_begin(mpi_rank)-1
+!	ENDIF  
+!      ENDDO
+!    ENDDO
+
+    routing_area => routing_area_glo  
+    topo_resid => topo_resid_glo
+    route_togrid => route_togrid_glo
+    route_tobasin => route_tobasin_glo
+    global_basinid => global_basinid_glo
+ 
+    IF (is_root_prc) CALL routing_basins(nbp_glo,lalo_g, neighbours_g, resolution_g, contfrac_g)
+
+    routing_area => routing_area_loc  
+    topo_resid => topo_resid_loc
+    route_togrid => route_togrid_loc
+    route_tobasin => route_tobasin_loc
+    global_basinid => global_basinid_loc
+
+    CALL scatter(routing_area_glo,routing_area_loc)
+    CALL scatter(topo_resid_glo,topo_resid_loc)
+    CALL scatter(route_togrid_glo,route_togrid_loc)
+    CALL scatter(route_tobasin_glo,route_tobasin_loc)
+    CALL scatter(global_basinid_glo,global_basinid_loc)
+    
+  END SUBROUTINE routing_basins_p
+  
+  SUBROUTINE routing_basins(nbpt, lalo, neighbours, resolution, contfrac)
+    !
+    IMPLICIT NONE
+    !
+    !
+    !  This subroutine reads in the map of basins and flow direction to construct the
+    !  the catchments of each grid box.
+    !
+    !  The work is done in a number of steps which are performed locally on the 
+    !  GCM grid:
+    !  1) First we find the grid-points of the high resolution routing grid which are
+    !     within the coarser grid of GCM.
+    !  2) When we have these grid points we decompose them into basins in the routine
+    !     routing_findbasins. A number of simplifications are done if needed.
+    !  3) In the routine routing_globalize we put the basin information of this grid
+    !     into global fields.
+    !  Then we work on the global grid to perform the following tasks :
+    !  1) We linkup the basins of the various and check the global consistence.
+    !  2) The area of each outflow point is computed.
+    !  3) The final step is to reduce the number of basins in order to fit into the truncation.
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)        ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)    :: neighbours(nbpt,8)  ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)  ! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)     ! Fraction of land in each grid box.
+    !
+    !
+    !  0.3 LOCAL
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt, lastjp, nbexp
+    REAL(r_std) :: lev(1), date, dt, coslat, pi
+    INTEGER(i_std) :: itau(1), sgn
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: trip, basins, topoindex, hierarchy
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, lat_ful, lon_ful
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: loup_rel, lolow_rel, laup_rel, lalow_rel
+    REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
+    !
+    INTEGER(i_std) :: nbi, nbj
+    REAL(r_std)    :: ax, ay, min_topoind, max_basins, invented_basins
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: sub_area
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: sub_pts
+    REAL(r_std), DIMENSION(nbvmax,nbvmax) :: area_bx, hierarchy_bx, lon_bx, lat_bx, topoind_bx
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax) ::  trip_bx, basin_bx
+    !
+    INTEGER(i_std) :: coast_pts(nbvmax)
+    REAL(r_std) :: lonrel, louprel, lolowrel
+    !
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: basin_count
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_id
+    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: basin_area, basin_hierarchy, basin_topoind
+    REAL(r_std),  ALLOCATABLE, DIMENSION(:,:)     :: fetch_basin
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: basin_flowdir
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: outflow_grid
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: outflow_basin
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: inflow_number
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:) :: inflow_basin, inflow_grid
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)     :: nbcoastal
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)   :: coastal_basin
+
+    !
+    INTEGER(i_std) :: nb_basin, nwbas
+    INTEGER(i_std) :: basin_inbxid(nbvmax), basin_sz(nbvmax), basin_pts(nbvmax,nbvmax,2), basin_bxout(nbvmax)
+    CHARACTER(LEN=7)   :: fmt
+    LOGICAL       :: debug = .FALSE.
+    INTEGER(i_std), DIMENSION(2) :: diagbox = (/ 1147, 1148 /) 
+
+    ! Test on diagbox and nbpt
+    IF (debug) THEN
+       IF (ANY(diagbox .GT. nbpt)) THEN 
+          WRITE(*,*) "Debug diganostics : nbpt, diagbox", nbpt, diagbox
+          call ipslerr(3,'routing_basin', &
+               &      'Problem with diagbox in debug mode.', & 
+               &      'diagbox values can''t be greater than land points number.', &
+               &      '(decrease diagbox wrong value)')
+       ENDIF
+    ENDIF
+    !
+    pi = 4. * ATAN(1.)
+    !
+    !  Needs to be a configurable variable
+    !
+    !
+    !Config Key  = ROUTING_FILE
+    !Config Desc = Name of file which contains the routing information
+    !Config Def  = routing.nc
+    !Config Help = The file provided here should alow the routing module to
+    !Config        read the high resolution grid of basins and the flow direction 
+    !Config        from one mesh to the other.
+    !
+    filename = 'routing.nc'
+    CALL getin('ROUTING_FILE',filename)
+    !
+    CALL flininfo(filename,iml, jml, lml, tml, fid)
+    !
+    !
+    ALLOCATE (lat_rel(iml,jml))
+    ALLOCATE (lon_rel(iml,jml))
+    ALLOCATE (laup_rel(iml,jml))
+    ALLOCATE (loup_rel(iml,jml))
+    ALLOCATE (lalow_rel(iml,jml))
+    ALLOCATE (lolow_rel(iml,jml))
+    ALLOCATE (lat_ful(iml+2,jml+2))
+    ALLOCATE (lon_ful(iml+2,jml+2))
+    ALLOCATE (trip(iml,jml))
+    ALLOCATE (basins(iml,jml))
+    ALLOCATE (topoindex(iml,jml))
+    ALLOCATE (hierarchy(iml,jml))
+    !
+    ALLOCATE (sub_area(nbpt,nbvmax))
+    ALLOCATE (sub_index(nbpt,nbvmax,2))
+    ALLOCATE (sub_pts(nbpt))
+    !
+
+    !
+    CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
+    !
+    ! The trip field follows the following convention for the flow of the water :
+    ! trip = 1 : flow = N
+    ! trip = 2 : flow = NE
+    ! trip = 3 : flow = E
+    ! trip = 4 : flow = SE
+    ! trip = 5 : flow = S
+    ! trip = 6 : flow = SW
+    ! trip = 7 : flow = W
+    ! trip = 8 : flow = NW
+    ! trip = 97 : return flow into the ground
+    ! trip = 98 : coastal flow (diffuse flow into the oceans)
+    ! trip = 99 : river flow into the oceans
+    !
+    !
+    CALL flinget(fid, 'trip', iml, jml, lml, tml, 1, 1, trip)
+    !
+    CALL flinget(fid, 'basins', iml, jml, lml, tml, 1, 1, basins)
+    !
+    CALL flinget(fid, 'topoind', iml, jml, lml, tml, 1, 1, topoindex)
+    !
+    CALL flinclo(fid)
+    !
+    nbexp = 0
+    !
+    min_topoind = MINVAL(topoindex, MASK=topoindex .LT. undef_sechiba-un)
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          IF ( trip(ip,jp) .LT. 1.e10 .AND. topoindex(ip,jp) .GT. 1.e10) THEN
+             WRITE(numout,*) 'trip exists but not topoind :'
+             WRITE(numout,*) 'ip, jp :', ip, jp
+             WRITE(numout,*) 'trip, topoind : ', trip(ip,jp), topoindex(ip,jp)
+             STOP
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    !    Duplicate the border assuming we have a global grid going from west to east
+    !
+    lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
+    lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
+    !
+    IF ( lon_rel(iml,1) .LT. lon_ful(2,2)) THEN
+       lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
+       lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+    ELSE
+       lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
+       lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+    ENDIF
+
+    IF ( lon_rel(1,1) .GT. lon_ful(iml+1,2)) THEN
+       lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
+       lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+    ELSE
+       lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
+       lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+    ENDIF
+    !
+    sgn = INT(lat_rel(1,1)/ABS(lat_rel(1,1)))
+    lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
+    sgn = INT(lat_rel(1,jml)/ABS(lat_rel(1,jml)))
+    lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
+    lat_ful(1,1) = lat_ful(iml+1,1)
+    lat_ful(iml+2,1) = lat_ful(2,1)
+    lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
+    lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
+    !
+    ! Add the longitude lines to the top and bottom
+    !
+    lon_ful(:,1) = lon_ful(:,2) 
+    lon_ful(:,jml+2) = lon_ful(:,jml+1) 
+    !
+    !  Get the upper and lower limits of each grid box
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          !
+          loup_rel(ip,jp) =MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
+               & 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+          lolow_rel(ip,jp) =MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)),&
+               & 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+          laup_rel(ip,jp) =MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
+               & 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+          lalow_rel(ip,jp) =MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)),&
+               & 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+          !
+       ENDDO
+    ENDDO
+    !
+    !
+    !
+    !   Now we take each grid point and find out which values from the forcing we need to average
+    !
+    DO ib =1, nbpt
+       !
+       !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+       !  into longitudes and latitudes we do not have the problem of periodicity.
+       ! coslat is a help variable here !
+       !
+       coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
+       !
+       lon_up = lalo(ib,2) + resolution(ib,1)/(2.0*coslat) 
+       lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+       !
+       coslat = pi/180. * R_Earth
+       !
+       lat_up =lalo(ib,1) + resolution(ib,2)/(2.0*coslat) 
+       lat_low =lalo(ib,1) - resolution(ib,2)/(2.0*coslat) 
+       !
+       !
+       !  Find the grid boxes from the data that go into the model's boxes
+       !  We still work as if we had a regular grid ! Well it needs to be localy regular so
+       !  so that the longitude at the latitude of the last found point is close to the one of the next point.
+       !
+       fopt = 0
+       lastjp = 1
+       DO ip=1,iml
+          !
+          !  Either the center of the data grid point is in the interval of the model grid or
+          !  the East and West limits of the data grid point are on either sides of the border of
+          !  the data grid.
+          !
+          !  To do that correctly we have to check if the grid box sits on the date-line.
+          !
+          IF ( lon_low < -180.0 ) THEN
+             lonrel = MOD( lon_rel(ip,lastjp) - 360.0, 360.0)
+             lolowrel = MOD( lolow_rel(ip,lastjp) - 360.0, 360.0)
+             louprel = MOD( loup_rel(ip,lastjp) - 360.0, 360.0)
+             !
+          ELSE IF ( lon_up > 180.0 ) THEN
+             lonrel = MOD( 360. - lon_rel(ip,lastjp), 360.0)
+             lolowrel = MOD( 360. - lolow_rel(ip,lastjp), 360.0)
+             louprel = MOD( 360. - loup_rel(ip,lastjp), 360.0)
+          ELSE
+             lonrel = lon_rel(ip,lastjp)
+             lolowrel = lolow_rel(ip,lastjp)
+             louprel = loup_rel(ip,lastjp)
+          ENDIF
+          !
+          !
+          !
+          IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
+               & lolowrel < lon_low .AND.  louprel > lon_low .OR. &
+               & lolowrel < lon_up  .AND.  louprel > lon_up ) THEN
+             !  
+             DO jp = 1, jml
+                !
+                ! Now that we have the longitude let us find the latitude
+                !
+                IF ( lat_rel(ip,jp) > lat_low .AND. lat_rel(ip,jp) < lat_up .OR. &
+                     & lalow_rel(ip,jp) < lat_low .AND. laup_rel(ip,jp) > lat_low .OR.&
+                     & lalow_rel(ip,jp) < lat_up .AND. laup_rel(ip,jp) > lat_up) THEN
+                   !
+                   lastjp = jp
+                   !
+                   !  Is it a land point ?
+                   !
+                   IF (trip(ip,jp) .LT. 1.e10) THEN
+                      !
+                      fopt = fopt + 1
+                      IF ( fopt .GT. nbvmax) THEN
+                         WRITE(numout,*) 'Please increase nbvmax in subroutine routing_basins', ib
+                         STOP
+                      ELSE
+                         !
+                         ! If we sit on the date line we need to do the same transformations as above.
+                         ! 
+                         IF ( lon_low < -180.0 ) THEN
+                            lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
+                            louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
+                            !
+                         ELSE IF ( lon_up > 180.0 ) THEN
+                            lolowrel = MOD( 360. - lolow_rel(ip,jp), 360.0)
+                            louprel = MOD( 360. - loup_rel(ip,jp), 360.0)
+                         ELSE
+                            lolowrel = lolow_rel(ip,jp)
+                            louprel = loup_rel(ip,jp)
+                         ENDIF
+                         !
+                         ! Get the area of the fine grid in the model grid
+                         !
+                         coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), 0.001 )
+                         ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
+                         ay = (MIN(lat_up, laup_rel(ip,jp))-MAX(lat_low,lalow_rel(ip,jp)))*pi/180. * R_Earth
+                         sub_area(ib, fopt) = ax*ay
+                         sub_index(ib, fopt, 1) = ip
+                         sub_index(ib, fopt, 2) = jp
+                      ENDIF
+                   ENDIF
+                   !
+                   sub_pts(ib) = fopt
+                   !
+                ENDIF
+                !
+             ENDDO
+             !
+          ENDIF
+          !
+       ENDDO
+       !
+       !
+    ENDDO
+    !
+    ! Do some memory management.
+    !
+    DEALLOCATE (laup_rel)
+    DEALLOCATE (loup_rel)
+    DEALLOCATE (lalow_rel)
+    DEALLOCATE (lolow_rel)
+    DEALLOCATE (lat_ful)
+    DEALLOCATE (lon_ful)
+    !
+    nwbas = MAXVAL(sub_pts)
+    !
+    ALLOCATE (basin_count(nbpt))
+    ALLOCATE (basin_area(nbpt,nwbas), basin_hierarchy(nbpt,nwbas), basin_topoind(nbpt,nwbas))
+    ALLOCATE (fetch_basin(nbpt,nwbas))
+    ALLOCATE (basin_id(nbpt,nwbas),  basin_flowdir(nbpt,nwbas))
+    ALLOCATE (outflow_grid(nbpt,nwbas),outflow_basin(nbpt,nwbas))
+    ALLOCATE (inflow_number(nbpt,nwbas))
+    ALLOCATE (inflow_basin(nbpt,nwbas,nbvmax), inflow_grid(nbpt,nwbas,nbvmax))
+    ALLOCATE (nbcoastal(nbpt), coastal_basin(nbpt,nwbas))
+    !
+    !    Order all sub points in each grid_box and find the sub basins
+    !
+    !    before we start we set the maps to empty
+    !
+    basin_id(:,:) = undef_int
+    basin_count(:) = 0
+    hierarchy(:,:) = undef_sechiba
+    max_basins = MAXVAL(basins, MASK=basins .LT. 1.e10)
+    invented_basins = max_basins
+    nbcoastal(:) = 0
+    !
+    CALL routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
+    !
+    !
+    DO ib =1, nbpt
+       !
+       !
+       !  extract the information for this grid box
+       !
+       CALL routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
+            & lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
+            & nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
+       !
+       CALL routing_findbasins(nbi, nbj, trip_bx, basin_bx, hierarchy_bx, topoind_bx,&
+            & nb_basin, basin_inbxid, basin_sz, basin_bxout, basin_pts, coast_pts)
+       !
+       !  Deal with the case where nb_basin=0 for this grid box. In this case all goes into coatal flow
+       !
+       IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
+          WRITE(numout,*) '===================== IB = :', ib
+          WRITE(numout,*) "sub_pts(ib) :", sub_pts(ib)
+          WRITE(numout,*) 'LON LAT of GCM :', lalo(ib,2), lalo(ib,1)
+          WRITE(numout,*) 'Neighbor options :',  neighbours(ib,1:8)
+          WRITE(numout,*) 'Resolution :', resolution(ib,1:2)
+          WRITE(fmt,"('(',I3,'I6)')") nbi
+          WRITE(numout,*) '-------------> trip ', trip_bx(1,1)
+          DO jp=1,nbj
+             WRITE(numout,fmt) trip_bx(1:nbi,jp)
+          ENDDO
+          WRITE(numout,*) '-------------> basin ',basin_bx(1,1)
+          DO jp=1,nbj
+             WRITE(numout,fmt) basin_bx(1:nbi,jp)
+          ENDDO
+          WRITE(numout,*) '-------------> hierarchy ',hierarchy_bx(1,1)
+          DO jp=1,nbj
+             WRITE(numout,fmt) INT(hierarchy_bx(1:nbi,jp)/1000.)
+          ENDDO
+          WRITE(numout,*) '-------------> topoindex ',topoind_bx(1,1)
+          DO jp=1,nbj
+             WRITE(numout,fmt) INT(topoind_bx(1:nbi,jp)/1000.)
+          ENDDO
+          !
+          WRITE(numout,*) '------------> The basins we retain'
+          DO jp=1,nb_basin
+             WRITE(numout,*) 'index, size, bxout, coast :', basin_inbxid(jp), basin_sz(jp),&
+                  & basin_bxout(jp), coast_pts(jp)
+          ENDDO
+          !
+       ENDIF
+       !
+       CALL routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
+            & nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
+            & basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
+            & nbcoastal, coastal_basin) 
+       !
+       IF ( debug .AND. (COUNT(diagbox .EQ. ib) .GT. 0) ) THEN
+          WRITE(numout,*) 'GLOBAL information after routing_globalize for grid ', ib
+          DO jp=1,basin_count(ib)
+             WRITE(numout,*) 'Basin ID : ', basin_id(ib, jp)
+             WRITE(numout,*) 'Basin flowdir :', basin_flowdir(ib, jp)
+             WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(ib, jp)
+             WRITE(numout,*) 'Basin topoindex :', basin_topoind(ib, jp)
+             WRITE(numout,*) 'Basin outflow grid :', outflow_grid(ib,jp)
+          ENDDO
+       ENDIF
+       !
+    ENDDO
+    !
+    CALL routing_linkup(nbpt, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
+         & basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, &
+         & nbcoastal, coastal_basin, invented_basins)
+    ! 
+    WRITE(numout,*) 'The maximum number of basins in any grid :', MAXVAL(basin_count)
+    !
+    IF ( debug ) THEN
+       DO ib=1,SIZE(diagbox)
+          IF ( diagbox(ib) .GT. 0 ) THEN
+             WRITE(numout,*) 'After routing_linkup information for grid ', diagbox(ib)
+             DO jp=1,basin_count(diagbox(ib))
+                WRITE(numout,*) 'Basin ID : ', basin_id(diagbox(ib), jp)
+                WRITE(numout,*) 'Basin outflow_grid :', outflow_grid(diagbox(ib), jp)
+                WRITE(numout,*) 'Basin outflow_basin:', outflow_basin(diagbox(ib), jp)
+                WRITE(numout,*) 'Basin hierarchy :', basin_hierarchy(diagbox(ib), jp)
+             ENDDO
+          ENDIF
+       ENDDO
+    ENDIF
+    !
+    CALL routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id, outflow_grid, &
+         & outflow_basin, fetch_basin)
+    !
+    WRITE(numout,*) "Start reducing the number of basins per grid to meet the required truncation."
+    !
+    CALL routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
+         & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
+         & inflow_grid, inflow_basin)
+    !
+    DEALLOCATE (lat_rel)
+    DEALLOCATE (lon_rel)
+    !
+    DEALLOCATE (trip)
+    DEALLOCATE (basins)
+    DEALLOCATE (topoindex)
+    DEALLOCATE (hierarchy)
+    !
+    DEALLOCATE (sub_area)
+    DEALLOCATE (sub_index)
+    DEALLOCATE (sub_pts)
+    !
+    DEALLOCATE (basin_count)
+    DEALLOCATE (basin_area, basin_hierarchy, basin_topoind, fetch_basin)
+    DEALLOCATE (basin_id,  basin_flowdir)
+    DEALLOCATE (outflow_grid,outflow_basin)
+    DEALLOCATE (inflow_number)
+    DEALLOCATE (inflow_basin, inflow_grid)
+    DEALLOCATE (nbcoastal, coastal_basin)
+    !
+    RETURN
+    !
+  END SUBROUTINE routing_basins
+  !
+  !-----------------------------------------------------------------------
+  !
+  SUBROUTINE routing_getgrid(nbpt, iml, jml, ib, sub_pts, sub_index, sub_area, max_basins, min_topoind, &
+       & lon_rel, lat_rel, lalo, resolution, contfrac, trip, basins, topoindex, hierarchy, &
+       & nbi, nbj, area_bx, trip_bx, basin_bx, topoind_bx, hierarchy_bx, lon_bx, lat_bx)
+    !
+    IMPLICIT NONE
+    !
+    ! Extracts from the global high resolution fileds the data for the current grid box
+    ! we are dealing with.
+    !
+    ! Convention for trip on the input :
+    ! The trip field follows the following convention for the flow of the water :
+    ! trip = 1 : flow = N
+    ! trip = 2 : flow = NE
+    ! trip = 3 : flow = E
+    ! trip = 4 : flow = SE
+    ! trip = 5 : flow = S
+    ! trip = 6 : flow = SW
+    ! trip = 7 : flow = W
+    ! trip = 8 : flow = NW
+    ! trip = 97 : return flow into the ground
+    ! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
+    ! trip = 99 : river flow into the oceans
+    !
+    ! On output, the grid boxes of the basin map which flow out of the GCM grid are identified
+    ! by numbers larger than 100 :
+    ! trip = 101 : flow = N out of the coarse grid
+    ! trip = 102 : flow = NE out of the coarse grid
+    ! trip = 103 : flow = E out of the coarse grid
+    ! trip = 104 : flow = SE out of the coarse grid
+    ! trip = 105 : flow = S out of the coarse grid
+    ! trip = 106 : flow = SW out of the coarse grid
+    ! trip = 107 : flow = W out of the coarse grid
+    ! trip = 108 : flow = NW out of the coarse grid
+    ! Inside the grid the convention remains the same as above (ie between 1 and 99).
+    !
+    !  INPUT
+    !
+    INTEGER(i_std), INTENT(in) :: nbpt              ! Number of points in the global grid
+    INTEGER(i_std), INTENT(in) :: iml, jml          ! Resolution of the high resolution grid
+    INTEGER(i_std), INTENT(in) :: ib                ! point we are currently dealing with
+    INTEGER(i_std), INTENT(in) :: sub_pts(nbpt)     ! Number of high resiolution points on this grid
+    INTEGER(i_std), INTENT(in) :: sub_index(nbpt, nbvmax,2) ! indeces of the points we need on the fine grid
+    REAL(r_std), INTENT(inout) :: max_basins        ! The current maximum of basins
+    REAL(r_std), INTENT(in)    :: min_topoind       ! The current maximum of topographic index
+    REAL(r_std), INTENT(in)    :: sub_area(nbpt, nbvmax)    ! area on the fine grid
+    REAL(r_std), INTENT(in)    :: lon_rel(iml, jml), lat_rel(iml, jml) ! coordinates of the fine grid
+    REAL(r_std), INTENT(in)    :: lalo(nbpt,2)        ! Vector of latitude and longitudes (beware of the order !)
+    REAL(r_std), INTENT(in)    :: resolution(nbpt,2)  ! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)    :: contfrac(nbpt)     ! Fraction of land in each grid box.
+    REAL(r_std), INTENT(inout) :: trip(iml, jml), basins(iml, jml)     ! data on the fine grid
+    REAL(r_std), INTENT(inout) :: topoindex(iml, jml), hierarchy(iml, jml) ! data on the fine grid
+    INTEGER(i_std), INTENT(out):: nbi, nbj           ! Number of point ion x and y within the grid
+    REAL(r_std), INTENT(out)   :: area_bx(nbvmax,nbvmax), hierarchy_bx(nbvmax,nbvmax)
+    REAL(r_std), INTENT(out)   :: lon_bx(nbvmax,nbvmax), lat_bx(nbvmax,nbvmax), topoind_bx(nbvmax,nbvmax)
+    INTEGER(i_std), INTENT(out):: trip_bx(nbvmax,nbvmax), basin_bx(nbvmax,nbvmax)
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std) :: ip, jp, ll(1), iloc, jloc
+    REAL(r_std)    :: lonstr(nbvmax*nbvmax), latstr(nbvmax*nbvmax)
+    !
+    !
+    ! Set everything to undef to locate easily empty points
+    !
+    trip_bx(:,:) = undef_int
+    basin_bx(:,:) = undef_int
+    topoind_bx(:,:) = undef_sechiba
+    area_bx(:,:) = undef_sechiba
+    hierarchy_bx(:,:) = undef_sechiba
+    !
+    IF ( sub_pts(ib) > 0 ) THEN
+       !
+       DO ip=1,sub_pts(ib)
+          lonstr(ip) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
+          latstr(ip) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
+       ENDDO
+       !
+       !  Get the size of the area and order the coordinates to go from North to South and West to East
+       !
+       CALL routing_sortcoord(sub_pts(ib), lonstr, 'WE', nbi)
+       CALL routing_sortcoord(sub_pts(ib), latstr, 'NS', nbj)
+       !
+       ! Transfer the data in such a way that (1,1) is the North Western corner and
+       ! (nbi, nbj) the South Eastern.
+       !
+       DO ip=1,sub_pts(ib)
+          ll = MINLOC(ABS(lonstr(1:nbi) - lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
+          iloc = ll(1)
+          ll = MINLOC(ABS(latstr(1:nbj) - lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))))
+          jloc = ll(1)
+          trip_bx(iloc, jloc) = NINT(trip(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
+          basin_bx(iloc, jloc) = NINT(basins(sub_index(ib, ip, 1), sub_index(ib, ip, 2)))
+          area_bx(iloc, jloc) = sub_area(ib, ip)
+          topoind_bx(iloc, jloc) = topoindex(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
+          hierarchy_bx(iloc, jloc) = hierarchy(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
+          lon_bx(iloc, jloc) = lon_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
+          lat_bx(iloc, jloc) = lat_rel(sub_index(ib, ip, 1), sub_index(ib, ip, 2))
+       ENDDO
+    ELSE
+       !
+       ! This is the case where the model invented a continental point
+       !
+       nbi = 1
+       nbj = 1
+       iloc = 1
+       jloc = 1
+       trip_bx(iloc, jloc) = 98
+       basin_bx(iloc, jloc) = NINT(max_basins + 1)
+       max_basins = max_basins + 1
+       area_bx(iloc, jloc) = resolution(ib,1)*resolution(ib,2)*contfrac(ib)
+       topoind_bx(iloc, jloc) = min_topoind
+       hierarchy_bx(iloc, jloc) =  min_topoind
+       lon_bx(iloc, jloc) = lalo(ib,2)
+       lat_bx(iloc, jloc) = lalo(ib,1)
+       !
+    ENDIF
+    !
+    ! Tag in trip all the outflow conditions. The table is thus :
+    ! trip = 100+n : Outflow into another grid-box
+    ! trip = 99    : River outflow into the ocean
+    ! trip = 98    : This will be coastal flow (not organized as a basin)
+    ! trip = 97    : return flow into the soil (local)
+    !
+    DO jp=1,nbj
+       IF ( trip_bx(1,jp) .EQ. 8 .OR. trip_bx(1,jp) .EQ. 7 .OR. trip_bx(1,jp) .EQ. 6) THEN
+          trip_bx(1,jp) = trip_bx(1,jp) + 100
+       ENDIF
+       IF ( trip_bx(nbi,jp) .EQ. 2 .OR. trip_bx(nbi,jp) .EQ. 3 .OR. trip_bx(nbi,jp) .EQ. 4) THEN
+          trip_bx(nbi,jp) = trip_bx(nbi,jp) + 100
+       ENDIF
+    ENDDO
+    DO ip=1,nbi
+       IF ( trip_bx(ip,1) .EQ. 8 .OR. trip_bx(ip,1) .EQ. 1 .OR. trip_bx(ip,1) .EQ. 2) THEN
+          trip_bx(ip,1) = trip_bx(ip,1) + 100
+       ENDIF
+       IF ( trip_bx(ip,nbj) .EQ. 6 .OR. trip_bx(ip,nbj) .EQ. 5 .OR. trip_bx(ip,nbj) .EQ. 4) THEN
+          trip_bx(ip,nbj) = trip_bx(ip,nbj) + 100
+       ENDIF
+    ENDDO
+    !
+    !
+    !  We simplify the outflow. We only need the direction normal to the
+    !     box boundary and the 4 corners.
+    ! 
+    ! Northern border
+    IF ( trip_bx(1,1) .EQ. 102 ) trip_bx(1,1) = 101
+    IF ( trip_bx(nbi,1) .EQ. 108 ) trip_bx(nbi,1) = 101
+    DO ip=2,nbi-1
+       IF ( trip_bx(ip,1) .EQ. 108 .OR. trip_bx(ip,1) .EQ. 102 ) trip_bx(ip,1) = 101
+    ENDDO
+    ! Southern border
+    IF ( trip_bx(1,nbj) .EQ. 104 ) trip_bx(1,nbj) = 105
+    IF ( trip_bx(nbi,nbj) .EQ. 106 ) trip_bx(nbi,nbj) = 105
+    DO ip=2,nbi-1
+       IF ( trip_bx(ip,nbj) .EQ. 104 .OR. trip_bx(ip,nbj) .EQ. 106 ) trip_bx(ip,nbj) = 105
+    ENDDO
+    ! Eastern border
+    IF ( trip_bx(nbi,1) .EQ. 104) trip_bx(nbi,1) = 103
+    IF ( trip_bx(nbi,nbj) .EQ. 102) trip_bx(nbi,nbj) = 103
+    DO jp=2,nbj-1
+       IF ( trip_bx(nbi,jp) .EQ. 104 .OR. trip_bx(nbi,jp) .EQ. 102 ) trip_bx(nbi,jp) = 103
+    ENDDO
+    ! Western border
+    IF ( trip_bx(1,1) .EQ. 106) trip_bx(1,1) = 107
+    IF ( trip_bx(1,nbj) .EQ. 108) trip_bx(1,nbj) = 107
+    DO jp=2,nbj-1
+       IF ( trip_bx(1,jp) .EQ. 106 .OR. trip_bx(1,jp) .EQ. 108 ) trip_bx(1,jp) = 107
+    ENDDO       
+    !
+    !
+  END SUBROUTINE routing_getgrid
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+  SUBROUTINE routing_sortcoord(nb_in, coords, direction, nb_out)
+    !
+    IMPLICIT NONE
+    !
+    ! Input/Output
+    !
+    INTEGER(i_std), INTENT(in)                    :: nb_in
+    REAL(r_std), INTENT(inout)                    :: coords(nb_in)
+    CHARACTER(LEN=2)                             :: direction
+    INTEGER(i_std), INTENT(out)                   :: nb_out
+    !
+    ! Local
+    !
+    INTEGER(i_std)                   :: ipos
+    REAL(r_std)                      :: coords_tmp(nb_in)
+    INTEGER(i_std), DIMENSION(1)     :: ll
+    INTEGER(i_std)                   :: ind(nb_in)
+    !
+    ipos = 1
+    nb_out = nb_in
+    !
+    ! Compress the coordinates array
+    !
+    DO WHILE ( ipos < nb_in )
+       IF ( coords(ipos+1) /= undef_sechiba) THEN
+         IF ( COUNT(coords(ipos:nb_out) == coords(ipos)) > 1 ) THEN
+            coords(ipos:nb_out-1) = coords(ipos+1:nb_out) 
+            coords(nb_out:nb_in) = undef_sechiba
+            nb_out = nb_out - 1
+         ELSE
+            ipos = ipos + 1
+         ENDIF
+      ELSE
+         EXIT
+      ENDIF
+    ENDDO
+    !
+    ! Sort it now
+    !
+    ! First we get ready and adjust for the periodicity in longitude
+    !
+    coords_tmp(:) = undef_sechiba
+    IF ( INDEX(direction, 'WE') == 1 .OR.  INDEX(direction, 'EW') == 1) THEN
+       IF ( MAXVAL(ABS(coords(1:nb_out))) .GT. 160 ) THEN
+          coords_tmp(1:nb_out) = MOD(coords(1:nb_out) + 360.0, 360.0)
+       ELSE
+          coords_tmp(1:nb_out) = coords(1:nb_out)
+       ENDIF
+    ELSE IF ( INDEX(direction, 'NS') == 1 .OR.  INDEX(direction, 'SN') == 1) THEN
+       coords_tmp(1:nb_out) = coords(1:nb_out)
+    ELSE
+       WRITE(numout,*) 'The chosen direction (', direction,') is not recognized'
+       STOP 'routing_sortcoord'
+    ENDIF
+    !
+    ! Get it sorted out now
+    !
+    ipos = 1
+    !
+    IF ( INDEX(direction, 'WE') == 1 .OR. INDEX(direction, 'SN') == 1) THEN
+       DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
+          ll = MINLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
+          ind(ipos) = ll(1) 
+          coords_tmp(ll(1)) = undef_sechiba
+          ipos = ipos + 1
+       ENDDO
+    ELSE IF ( INDEX(direction, 'EW') == 1 .OR. INDEX(direction, 'NS') == 1) THEN
+       DO WHILE (COUNT(ABS(coords_tmp(:)-undef_sechiba) > EPSILON(undef_sechiba)*10.) >= 1)
+          ll = MAXLOC(coords_tmp(:), coords_tmp /= undef_sechiba)
+          ind(ipos) = ll(1) 
+          coords_tmp(ll(1)) = undef_sechiba
+          ipos = ipos + 1
+       ENDDO
+    ELSE
+       WRITE(numout,*) 'The chosen direction (', direction,') is not recognized (second)'
+       STOP 'routing_sortcoord'
+    ENDIF
+    !
+    coords(1:nb_out) = coords(ind(1:nb_out))
+    IF (nb_out < nb_in) THEN
+       coords(nb_out+1:nb_in) = zero
+    ENDIF
+    !
+  END SUBROUTINE routing_sortcoord
+  !
+  !-------------------------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_findbasins(nbi, nbj, trip, basin, hierarchy, topoind, nb_basin, basin_inbxid, basin_sz,&
+       & basin_bxout, basin_pts, coast_pts)
+    !
+    IMPLICIT NONE
+    !
+    !  This subroutine find the basins and does some clean up. The aim is to return the list off all
+    !  points which are within the same basin of the grid_box.
+    !  We will also collect all points which directly flow into the ocean in one basin
+    !  Make sure that we do not have a basin with two outflows and other exceptions.
+    !
+    !  At this stage no effort is made to come down to the truncation of the model.
+    !
+    ! Convention for trip
+    ! -------------------
+    ! Inside of the box :
+    ! trip = 1 : flow = N
+    ! trip = 2 : flow = NE
+    ! trip = 3 : flow = E
+    ! trip = 4 : flow = SE
+    ! trip = 5 : flow = S
+    ! trip = 6 : flow = SW
+    ! trip = 7 : flow = W
+    ! trip = 8 : flow = NW
+    ! trip = 97 : return flow into the ground
+    ! trip = 98 : coastal flow (diffuse flow into the oceans) These values are created here
+    ! trip = 99 : river flow into the oceans
+    !
+    ! Out flow from the gird :
+    ! trip = 101 : flow = N out of the coarse grid
+    ! trip = 102 : flow = NE out of the coarse grid
+    ! trip = 103 : flow = E out of the coarse grid
+    ! trip = 104 : flow = SE out of the coarse grid
+    ! trip = 105 : flow = S out of the coarse grid
+    ! trip = 106 : flow = SW out of the coarse grid
+    ! trip = 107 : flow = W out of the coarse grid
+    ! trip = 108 : flow = NW out of the coarse grid
+    !
+    !  Inputs
+    !
+    INTEGER(i_std) :: nbi, nbj
+    INTEGER(i_std) :: trip(:,:), basin(:,:)
+    REAL(r_std)    :: hierarchy(:,:), topoind(:,:)
+    !
+    !  Outputs
+    !
+    INTEGER(i_std) :: nb_basin
+    INTEGER(i_std) :: basin_inbxid(nbvmax), basin_sz(nbvmax), basin_bxout(nbvmax)
+    INTEGER(i_std) :: basin_pts(nbvmax, nbvmax, 2)
+    INTEGER(i_std) :: coast_pts(nbvmax)
+    !
+    !  Local
+    !
+    INTEGER(i_std) :: ibas, ilf, nbb, nb_in
+    INTEGER(i_std) :: bname(nbvmax), sz(nbvmax), pts(nbvmax,nbvmax,2), nbout(nbvmax)
+    INTEGER(i_std) :: new_nb, new_bname(nbvmax), new_sz(nbvmax), new_pts(nbvmax,nbvmax,2)
+    INTEGER(i_std) :: itrans, trans(nbvmax), outdir(nbvmax)
+    INTEGER(i_std) :: tmpsz(nbvmax)
+    INTEGER(i_std) :: ip, jp, jpp(1), ipb
+    INTEGER(i_std) :: sortind(nbvmax)
+    CHARACTER(LEN=7)   :: fmt
+    !
+    nbb = 0
+    bname(:) = undef_int
+    sz(:) = 0
+    nbout(:) = 0
+    new_pts(:,:,:) = 0
+    !
+    ! 1.0 Find all basins within this grid-box
+    !     Sort the variables per basin so that we can more easily
+    !     access data from the same basin (The variables are :
+    !     bname, sz, pts, nbout)
+    !
+    DO ip=1,nbi
+       DO jp=1,nbj
+          IF ( basin(ip,jp) .LT. undef_int) THEN
+             IF ( COUNT(basin(ip,jp) .EQ. bname(:)) .EQ. 0 ) THEN
+                nbb = nbb + 1
+                IF ( nbb .GT. nbvmax ) STOP 'nbvmax too small'
+                bname(nbb) = basin(ip,jp)
+                sz(nbb) = 0
+             ENDIF
+             !
+             DO ilf=1,nbb
+                IF ( basin(ip,jp) .EQ. bname(ilf) ) THEN
+                   ibas = ilf
+                ENDIF
+             ENDDO
+             !
+             sz(ibas) = sz(ibas) + 1
+             IF ( sz(ibas) .GT. nbvmax ) STOP 'nbvmax too small'
+             pts(ibas, sz(ibas), 1) = ip
+             pts(ibas, sz(ibas), 2) = jp
+             ! We deal only with outflow and leave flow back into the grid-box for later.
+             IF ( trip(ip,jp) .GE. 97 ) THEN
+                nbout(ibas) = nbout(ibas) + 1
+             ENDIF
+             !
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    ! 2.0 All basins which have size 1 and flow to the ocean are put together.
+    !
+    itrans = 0
+    coast_pts(:) = undef_int
+    ! Get all the points we can collect
+    DO ip=1,nbb
+       IF ( sz(ip) .EQ. 1 .AND. trip(pts(ip,1,1),pts(ip,1,2)) .EQ. 99) THEN
+          itrans = itrans + 1
+          trans(itrans) = ip
+          trip(pts(ip,1,1),pts(ip,1,2)) = 98
+       ENDIF
+    ENDDO
+    ! put everything in the first basin
+    IF ( itrans .GT. 1) THEN
+       ipb = trans(1)
+       coast_pts(sz(ipb)) = bname(ipb)
+       bname(ipb) = -1
+       DO ip=2,itrans
+          sz(ipb) = sz(ipb) + 1
+          coast_pts(sz(ipb)) = bname(trans(ip))
+          sz(trans(ip)) = 0
+          pts(ipb, sz(ipb), 1) = pts(trans(ip), 1, 1) 
+          pts(ipb, sz(ipb), 2) = pts(trans(ip), 1, 2) 
+       ENDDO
+    ENDIF
+    !
+    ! 3.0 Make sure that we have only one outflow point in each basin
+    !
+    ! nbb is the number of basins on this grid box.
+    new_nb = 0
+    DO ip=1,nbb
+       ! We only do this for grid-points which have more than one outflow
+       IF ( sz(ip) .GT. 1 .AND. nbout(ip) .GT. 1) THEN
+          !
+          ! Pick up all points needed and store them in trans
+          !
+          itrans = 0
+          DO jp=1,sz(ip)
+             IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 97) THEN
+                itrans = itrans + 1
+                trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
+             ENDIF
+          ENDDO
+          !
+          ! First issue : We have more than one point of the basin which flows into
+          ! the ocean. In this case we put everything into coastal flow. It will go into
+          ! a separate basin in the routing_globalize routine.
+          !
+          IF ( (COUNT(trans(1:itrans) .EQ. 99) + COUNT(trans(1:itrans) .EQ. 98)) .GT. 1) THEN
+             DO jp=1,sz(ip)
+                IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .EQ. 99 ) THEN
+                   trip(pts(ip,jp,1),pts(ip,jp,2)) = 98
+                   trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
+                ENDIF
+             ENDDO
+          ENDIF
+          !
+          ! Second issue : We have redundant outflows at the boundaries. That is two small grid
+          ! boxes flowing into the same GCM grid box.
+          !
+          IF ( COUNT(trans(1:itrans) .GT. 100) .GE. 1) THEN
+             CALL routing_simplify(nbi, nbj, trip, basin, hierarchy, bname(ip))
+             itrans = 0
+             DO jp=1,sz(ip)
+                IF ( trip(pts(ip,jp,1),pts(ip,jp,2)) .GE. 9) THEN
+                   itrans = itrans + 1
+                   trans(itrans) = trip(pts(ip,jp,1),pts(ip,jp,2))
+                ENDIF
+             ENDDO
+          ENDIF
+          !
+          ! Third issue : we have more than one outflow from the boxes. This could be 
+          !             - flow into 2 or more neighboring GCM grids
+          !             - flow into a neighboring GCM grids and into the ocean or be a return flow (=97. =98, =99)
+          !             - flow into a neighboring GCM grids or ocean and back into the same GCM grid box
+          ! The only solution is to cut the basin up in as many parts.
+          !
+          IF ( COUNT(trans(1:itrans) .GE. 97) .GT. 1) THEN
+             !
+             nb_in =  new_nb
+             CALL routing_cutbasin(nbi, nbj, nbb, trip, basin, bname(ip), new_nb, new_bname, new_sz, new_pts)
+             !
+             ! If we have split the basin then we need to cancel the old one
+             !
+             IF ( nb_in .NE. new_nb) THEN
+                sz(ip) = 0
+             ENDIF
+             !
+          ENDIF
+          !
+       ENDIF
+    ENDDO
+    !
+    !  Add the new basins to the end of the list
+    !
+    If ( nbb+new_nb .LE. nbvmax) THEN
+       DO ip=1,new_nb
+          bname(nbb+ip) = new_bname(ip)
+          sz(nbb+ip) = new_sz(ip)
+          pts(nbb+ip,:,:) = new_pts(ip,:,:)
+       ENDDO
+       nbb = nbb+new_nb
+    ELSE
+       WRITE(numout,*) 'Increase nbvmax. It is too small to contain all the basins (routing_findbasins)'
+       STOP
+    ENDIF
+    !
+    ! Keep the output direction
+    !
+    DO ip=1,nbb
+       IF ( sz(ip) .GT. 0 ) THEN
+          trans(:) = 0
+          DO jp=1,sz(ip)
+             trans(jp) = trip(pts(ip,jp,1),pts(ip,jp,2))
+          ENDDO
+          outdir(ip) = MAXVAL(trans(1:sz(ip)))
+          IF ( outdir(ip) .GE. 97 ) THEN
+             outdir(ip) = outdir(ip) - 100
+          ELSE
+             WRITE(numout,*) 'Why are we here and can not find a trip larger than 96'
+             WRITE(numout,*) 'Does this mean that the basin does not have any outflow ', ip, bname(ip)
+             WRITE(fmt,"('(',I3,'I9)')") nbi
+             WRITE(numout,*) '-----------------------> trip'
+             DO jp=1,nbj
+                WRITE(numout,fmt) trip(1:nbi,jp)
+             ENDDO
+             WRITE(numout,*) '-----------------------> basin'
+             DO jp=1,nbj
+                WRITE(numout,fmt) basin(1:nbi,jp)
+             ENDDO
+             STOP 'SUBROUTINE : routing_findbasins'
+          ENDIF
+       ENDIF
+    ENDDO
+    !
+    !
+    ! Sort the output by size of the various basins. 
+    !
+    nb_basin = COUNT(sz(1:nbb) .GT. 0)
+    tmpsz(:) = -1
+    tmpsz(1:nbb) = sz(1:nbb)
+    DO ip=1,nbb
+       jpp = MAXLOC(tmpsz(:))
+       IF ( sz(jpp(1)) .GT. 0) THEN
+          sortind(ip) = jpp(1)
+          tmpsz(jpp(1)) = -1
+       ENDIF
+    ENDDO
+    basin_inbxid(1:nb_basin) = bname(sortind(1:nb_basin))
+    basin_sz(1:nb_basin) = sz(sortind(1:nb_basin))
+    basin_pts(1:nb_basin,:,:) = pts(sortind(1:nb_basin),:,:)
+    basin_bxout(1:nb_basin) = outdir(sortind(1:nb_basin))
+    !
+    ! We can only check if we have at least as many outflows as basins
+    !
+    ip = COUNT(trip(1:nbi,1:nbj) .GE. 97 .AND. trip(1:nbi,1:nbj) .LT. undef_int)
+!!    ip = ip + COUNT(trip(1:nbi,1:nbj) .EQ. 97)
+!!    IF ( COUNT(trip(1:nbi,1:nbj) .EQ. 98) .GT. 0) ip = ip + 1
+    IF ( ip .LT. nb_basin ) THEN
+       WRITE(numout,*) 'We have less outflow points than basins :', ip
+       WRITE(fmt,"('(',I3,'I9)')") nbi
+       WRITE(numout,*) '-----------------------> trip'
+       DO jp=1,nbj
+          WRITE(numout,fmt) trip(1:nbi,jp)
+       ENDDO
+       WRITE(numout,*) '-----------------------> basin'
+       DO jp=1,nbj
+          WRITE(numout,fmt) basin(1:nbi,jp)
+       ENDDO
+       WRITE(numout,*) 'nb_basin :', nb_basin
+       WRITE(numout,*) 'Basin sized :', basin_sz(1:nb_basin)
+       STOP 'in routing_findbasins'
+    ENDIF
+    !
+  END SUBROUTINE routing_findbasins
+  !
+  ! ------------------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_simplify(nbi, nbj, trip, basin, hierarchy, basin_inbxid)
+    !
+    IMPLICIT NONE
+    !
+    !  This subroutine symplifies the routing out of each basin by taking
+    !  out redundancies at the borders of the GCM box. The aim is to have
+    !  only one outflow point per basin. But here we will not change the
+    !  the direction of the outflow.
+    !
+    !  Inputs
+    INTEGER(i_std) :: nbi, nbj
+    INTEGER(i_std) :: trip(:,:), basin(:,:)
+    REAL(r_std)    :: hierarchy(:,:)
+    INTEGER(i_std) :: basin_inbxid
+    !
+    !  Local
+    !
+    INTEGER(i_std) :: ip, jp, nbout, basin_sz, iborder
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_tmp
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow
+    INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow
+    INTEGER(i_std), DIMENSION(nbvmax)   :: outsz
+    CHARACTER(LEN=7)   :: fmt
+    !
+    INTEGER(i_std), DIMENSION(8,2)    :: inc
+    INTEGER(i_std)                    :: itodo, ill(1), icc, ismall, ibas, iip, jjp, ib, id
+    INTEGER(i_std), DIMENSION(nbvmax) :: todopt, todosz
+    REAL(r_std), DIMENSION(nbvmax)    :: todohi
+    LOGICAL                          :: not_found, debug = .FALSE.
+    !
+    !
+    !  The routing code (i=1, j=2)
+    !
+    inc(1,1) = 0
+    inc(1,2) = -1
+    inc(2,1) = 1
+    inc(2,2) = -1
+    inc(3,1) = 1
+    inc(3,2) = 0
+    inc(4,1) = 1
+    inc(4,2) = 1
+    inc(5,1) = 0
+    inc(5,2) = 1
+    inc(6,1) = -1
+    inc(6,2) = 1
+    inc(7,1) = -1
+    inc(7,2) = 0
+    inc(8,1) = -1
+    inc(8,2) = -1
+    !
+    !
+    !  Symplify the outflow conditions first. We are only interested in the
+    !  outflows which go to different GCM grid-boxes.
+    !
+    IF ( debug ) THEN
+       WRITE(numout,*) '+++++++++++++++++++ BEFORE ANYTHING ++++++++++++++++++++'
+       WRITE(fmt,"('(',I3,'I6)')") nbi
+       DO jp=1,nbj
+          WRITE(numout,fmt) trip_tmp(1:nbi,jp)
+       ENDDO
+    ENDIF
+    !
+    !  transfer the trips into an array which only contains the basin we are interested in
+    !
+    trip_tmp(:,:) = -1
+    basin_sz = 0
+    DO ip=1,nbi
+       DO jp=1,nbj
+          IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
+             trip_tmp(ip,jp) = trip(ip,jp)
+             basin_sz = basin_sz + 1
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! Determine for each point where it flows to
+    !
+    CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
+    !
+    !
+    !
+    !
+    ! Over the width of a GCM grid box we can have many outflows but we are interested
+    ! in only one for each basin. Thus we wish to collect them all to form only one outflow
+    ! to the neighboring grid-box.
+    !
+    DO iborder = 101,107,2
+       !
+       ! If we have more than one of these outflows then we need to merge the sub-basins
+       !
+       icc = COUNT(trip_tmp .EQ. iborder)-1
+       DO WHILE ( icc .GT. 0)
+          ! Pick out all the points we will have to do
+          itodo = 0
+          DO ip=1,nbout
+             IF (trip_tmp(outflow(ip,1),outflow(ip,2)) .EQ. iborder) THEN
+                itodo = itodo + 1
+                todopt(itodo) = ip
+                todosz(itodo) = outsz(ip)
+                ! We take the hierarchy of the outflow point as we will try to
+                ! minimize if for the outflow of the entire basin.
+                todohi(itodo) = hierarchy(outflow(ip,1),outflow(ip,2))
+             ENDIF
+          ENDDO
+          !
+          ! We change the direction of the smalest basin.
+          !
+          ill=MAXLOC(todohi(1:itodo))
+          ismall = todopt(ill(1))
+          !
+          DO ip=1,nbi
+             DO jp=1,nbj
+                IF ( trip_flow(ip,jp,1) .EQ. outflow(ismall,1) .AND.&
+                     & trip_flow(ip,jp,2) .EQ. outflow(ismall,2) ) THEN
+                   ! Now that we have found a point of the smallest sub-basin we 
+                   ! look around for another sub-basin
+                   ib = 1
+                   not_found = .TRUE.
+                   DO WHILE ( not_found .AND. ib .LE. itodo ) 
+                      IF ( ib .NE. ill(1) ) THEN
+                         ibas = todopt(ib)
+                         DO id=1,8
+                            iip = ip + inc(id,1)
+                            jjp = jp + inc(id,2)
+                            ! Can we look at this points or is there any need to ?
+                            IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
+                                 & jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
+                               ! Is this point the one we look for ?
+                               IF ( trip_flow(iip,jjp,1) .EQ. outflow(ibas,1) .AND. &
+                                    & trip_flow(iip,jjp,2) .EQ. outflow(ibas,2)) THEN
+                                  trip_flow(ip,jp,1) = outflow(ibas,1)
+                                  trip_flow(ip,jp,2) = outflow(ibas,2)
+                                  trip_tmp(ip,jp) = id
+                                  ! This last line ensures that we do not come back to this point
+                                  ! and that in the end the outer while will stop
+                                  not_found = .FALSE.
+                               ENDIF
+                            ENDIF
+                         ENDDO
+                      ENDIF
+                      ib = ib + 1
+                   ENDDO
+                ENDIF
+             ENDDO
+          ENDDO
+          !
+          icc = icc - 1
+       ENDDO
+       !
+       !
+    ENDDO
+    !
+    IF ( debug ) THEN
+       WRITE(numout,*) '+++++++++++++++++++ AFTER +++++++++++++++++++++++++++++'
+       WRITE(fmt,"('(',I3,'I6)')") nbi
+       DO jp=1,nbj
+          WRITE(numout,fmt) trip_tmp(1:nbi,jp)
+       ENDDO
+    ENDIF
+    !
+    !  Put trip_tmp back into trip
+    !
+    DO ip=1,nbi
+       DO jp=1,nbj
+          IF ( trip_tmp(ip,jp) .GT. 0) THEN
+             trip(ip,jp) = trip_tmp(ip,jp)
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+  END SUBROUTINE routing_simplify
+!
+!-------------------------------------
+!
+  SUBROUTINE routing_cutbasin (nbi, nbj, nbbasins, trip, basin, basin_inbxid, nb, bname, sz, pts)
+    !
+    IMPLICIT NONE
+    !
+    !  This subroutine cuts the original basin which has more than one outflow into as
+    !  many subbasins as outflow directions.
+    !
+    !  Inputs
+    INTEGER(i_std) :: nbi, nbj
+    INTEGER(i_std) :: nbbasins
+    INTEGER(i_std) :: trip(:,:), basin(:,:)
+    INTEGER(i_std) :: basin_inbxid
+    !
+    !  Outputs
+    !
+    INTEGER(i_std) :: nb, bname(nbvmax), sz(nbvmax), pts(nbvmax,nbvmax,2)
+    !
+    !  Local
+    !
+    INTEGER(i_std) :: ip, jp, iip, jjp, ib, ibb, id, nbout
+    INTEGER(i_std) :: basin_sz, nb_in
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax) :: trip_tmp
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow
+    INTEGER(i_std), DIMENSION(nbvmax,2) :: outflow
+    INTEGER(i_std), DIMENSION(nbvmax)   :: outsz
+    CHARACTER(LEN=7)   :: fmt
+    LOGICAL       :: not_found, debug=.FALSE.
+    !
+    INTEGER(i_std), DIMENSION(8,2) :: inc
+    !
+    !
+    !  The routing code (i=1, j=2)
+    !
+    inc(1,1) = 0
+    inc(1,2) = -1
+    inc(2,1) = 1
+    inc(2,2) = -1
+    inc(3,1) = 1
+    inc(3,2) = 0
+    inc(4,1) = 1
+    inc(4,2) = 1
+    inc(5,1) = 0
+    inc(5,2) = 1
+    inc(6,1) = -1
+    inc(6,2) = 1
+    inc(7,1) = -1
+    inc(7,2) = 0
+    inc(8,1) = -1
+    inc(8,2) = -1
+    !
+    ! Set up a temporary trip field which only contains the values
+    ! for the basin on which we currently work.
+    !
+    trip_tmp(:,:) = -1
+    basin_sz = 0
+    DO ip=1,nbi
+       DO jp=1,nbj
+          IF ( basin(ip,jp) .EQ. basin_inbxid) THEN
+             trip_tmp(ip,jp) = trip(ip,jp)
+             basin_sz = basin_sz + 1
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    CALL routing_findrout(nbi, nbj, trip_tmp, basin_sz, basin_inbxid, nbout, outflow, trip_flow, outsz)
+    ! 
+!!    IF ( debug ) THEN
+!!       DO ib = nb_in+1,nb
+!!          DO ip=1,sz(ib)
+!!             trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
+!!          ENDDO
+!!       ENDDO
+!!       WRITE(fmt,"('(',I3,'I6)')") nbi
+!!       WRITE(numout,*)  'BEFORE ------------> New basins '
+!!       WRITE(numout,*) nb, ' sz :', sz(1:nb)
+!!       DO jp=1,nbj
+!!          WRITE(numout,fmt) trip_tmp(1:nbi,jp)
+!!       ENDDO
+!!    ENDIF
+    !
+    !  Take out the small sub-basins. That is those which have only one grid box
+    !  This is only done if we need to save space in the number of basins. Else we
+    !  can take it easy and keep diverging sub-basins for the moment. 
+    !
+    IF ( nbbasins .GE. nbasmax ) THEN
+       DO ib=1,nbout
+          ! If the sub-basin is of size one and its larger neighbor is flowing into another
+          ! direction then we put them together.
+          IF ( outsz(ib) .EQ. 1 .AND. trip(outflow(ib,1), outflow(ib,2)) .GT. 99 ) THEN
+             !
+             not_found = .TRUE.
+             DO id=1,8
+                ip = outflow(ib,1)
+                jp = outflow(ib,2)
+                iip = ip + inc(id,1)
+                jjp = jp + inc(id,2)
+                ! Can we look at this points ?
+                IF ( iip .GE. 1 .AND. iip .LE. nbi .AND. &
+                     & jjp .GE. 1 .AND. jjp .LE. nbj .AND. not_found) THEN
+                   ! Did we find a direct neighbor which is an outflow point ?
+                   IF ( trip_tmp(iip,jjp) .GT. 100 ) THEN
+                      ! IF so direct the flow towards it and update the tables.
+                      not_found = .FALSE.
+                      trip(ip,jp) = id
+                      trip_tmp(ip,jp) = id
+                      outsz(ib) = 0
+                      ! update the table of this basin
+                      DO ibb=1,nbout
+                         IF ( iip .EQ. outflow(ibb,1) .AND. jjp .EQ. outflow(ibb,2) ) THEN
+                            outsz(ibb) = outsz(ibb)+1 
+                            trip_flow(ip,jp,1) = outflow(ibb,1)
+                            trip_flow(ip,jp,2) = outflow(ibb,2)
+                         ENDIF
+                      ENDDO
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDIF
+       ENDDO
+    ENDIF
+    !
+    !
+    !  Cut the basin if we have more than 1 left.
+    !
+    !
+    IF ( COUNT(outsz(1:nbout) .GT. 0) .GT. 1 ) THEN
+       !
+       nb_in = nb
+       !
+       DO ib = 1,nbout
+          IF ( outsz(ib) .GT. 0) THEN
+             nb = nb+1
+             IF ( nb .GT. nbvmax) THEN
+                WRITE(numout,*) 'nbvmax too small, increase it (routing_cutbasin)'
+             ENDIF
+             bname(nb) = basin_inbxid
+             sz(nb) = 0
+             DO ip=1,nbi
+                DO jp=1,nbj
+                   IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,1)) .GT. 0 .AND. &
+                      & trip_flow(ip,jp,1) .EQ. outflow(ib,1) .AND. &
+                      & trip_flow(ip,jp,2) .EQ. outflow(ib,2) ) THEN
+                      sz(nb) = sz(nb) + 1
+                      pts(nb, sz(nb), 1) = ip
+                      pts(nb, sz(nb), 2) = jp
+                   ENDIF
+                ENDDO
+             ENDDO
+          ENDIF
+       ENDDO
+       ! A short verification 
+       IF ( SUM(sz(nb_in+1:nb)) .NE. basin_sz) THEN
+          WRITE(numout,*) 'Lost some points while spliting the basin'
+          WRITE(numout,*) 'nbout :', nbout
+          DO ib = nb_in+1,nb
+             WRITE(numout,*) 'ib, SZ :', ib, sz(ib)
+          ENDDO
+          WRITE(fmt,"('(',I3,'I6)')") nbi
+          WRITE(numout,*)  '-------------> trip '
+          DO jp=1,nbj
+             WRITE(numout,fmt) trip_tmp(1:nbi,jp)
+          ENDDO
+          STOP
+       ENDIF
+       !
+       IF ( debug ) THEN
+          DO ib = nb_in+1,nb
+             DO ip=1,sz(ib)
+                trip_tmp(pts(ib, ip, 1),pts(ib, ip, 2)) = ib*(-1)-900
+             ENDDO
+          ENDDO
+          WRITE(fmt,"('(',I3,'I6)')") nbi
+          WRITE(numout,*)  'AFTER-------------> New basins '
+          WRITE(numout,*) nb, ' sz :', sz(1:nb)
+          DO jp=1,nbj
+             WRITE(numout,fmt) trip_tmp(1:nbi,jp)
+          ENDDO
+          IF ( MAXVAl(trip_tmp(1:nbi,1:nbj)) .GT. 0) THEN
+             STOP
+          ENDIF
+       ENDIF
+    ENDIF
+    !
+  END SUBROUTINE routing_cutbasin
+  !
+  !------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_hierarchy(iml, jml, trip, topoindex, hierarchy)
+    !
+    IMPLICIT NONE
+    !
+    !  This subroutine will find for each point the distance to the outflow point
+    !  along the flowlines of the basin.
+    !
+    INTEGER(i_std) :: iml, jml
+    REAL(r_std), DIMENSION(iml,jml) :: trip, hierarchy, topoindex
+    !
+    INTEGER(i_std), DIMENSION(8,2) :: inc
+    INTEGER(i_std)                 :: ip, jp, ib, ntripi, ntripj, cnt, trp
+    REAL(r_std)                    :: topohier, topohier_old
+    CHARACTER(LEN=7)   :: fmt
+    !
+    !  The routing code (i=1, j=2)
+    !
+    inc(1,1) = 0
+    inc(1,2) = -1
+    inc(2,1) = 1
+    inc(2,2) = -1
+    inc(3,1) = 1
+    inc(3,2) = 0
+    inc(4,1) = 1
+    inc(4,2) = 1
+    inc(5,1) = 0
+    inc(5,2) = 1
+    inc(6,1) = -1
+    inc(6,2) = 1
+    inc(7,1) = -1
+    inc(7,2) = 0
+    inc(8,1) = -1
+    inc(8,2) = -1
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          IF ( trip(ip,jp) .LT. undef_sechiba ) THEN
+             ntripi = ip
+             ntripj = jp
+             trp = trip(ip,jp)
+             cnt = 1
+             ! Warn for extreme numbers
+             IF (  topoindex(ip,jp) .GT. 1.e10 ) THEN
+                WRITE(numout,*) 'We have a very large topographic index for point ', ip, jp
+                WRITE(numout,*) 'This can not be right :', topoindex(ip,jp)
+                STOP
+             ELSE
+                topohier = topoindex(ip,jp)
+             ENDIF
+             !
+             DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. iml*jml) 
+                cnt = cnt + 1
+                ntripi = ntripi + inc(trp,1)
+                IF ( ntripi .LT. 1) ntripi = iml
+                IF ( ntripi .GT. iml) ntripi = 1
+                ntripj = ntripj + inc(trp,2)
+                topohier_old = topohier
+                topohier = topohier + topoindex(ntripi, ntripj)
+                IF ( topohier_old .GT. topohier) THEN
+                   WRITE(numout,*) 'Big Problem, how comes we climb up a hill ?'
+                   WRITE(numout,*) 'The old value of topographicaly weighted hierarchy was : ', topohier_old
+                   WRITE(numout,*) 'The new one is :', topohier
+                   STOP 'routing_hierarchy'
+                ENDIF
+                trp = trip(ntripi, ntripj)
+             ENDDO
+             !
+             IF ( cnt .EQ. iml*jml) THEN
+                WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
+                WRITE(numout,*) '-------------> trip '
+                WRITE(fmt,"('(',I3,'I6)')") iml
+                DO ib=1,jml
+                   WRITE(numout,fmt) trip(1:iml,ib)
+                ENDDO
+                STOP
+             ENDIF
+             !
+             hierarchy(ip,jp) = topohier
+             !
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    !
+  END SUBROUTINE routing_hierarchy
+  !
+  !------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_findrout(nbi, nbj, trip, basin_sz, basinid, nbout, outflow, trip_flow, outsz)
+    !
+    IMPLICIT NONE
+    !
+    ! This subroutine simply computes the route to each outflow point and returns
+    ! the outflow point for each point in the basin.
+    !
+    ! INPUT
+    !
+    INTEGER(i_std)                             :: nbi, nbj
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)   :: trip
+    INTEGER(i_std)                             :: basin_sz, basinid, nbout
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2) :: trip_flow
+    INTEGER(i_std), DIMENSION(nbvmax,2)        :: outflow
+    INTEGER(i_std), DIMENSION(nbvmax)          :: outsz
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std), DIMENSION(8,2) :: inc
+    INTEGER(i_std)                 :: ip, jp, ib, cnt, trp, totsz
+    CHARACTER(LEN=7)   :: fmt
+    !
+    !
+    !  The routing code (i=1, j=2)
+    !
+    inc(1,1) = 0
+    inc(1,2) = -1
+    inc(2,1) = 1
+    inc(2,2) = -1
+    inc(3,1) = 1
+    inc(3,2) = 0
+    inc(4,1) = 1
+    inc(4,2) = 1
+    inc(5,1) = 0
+    inc(5,2) = 1
+    inc(6,1) = -1
+    inc(6,2) = 1
+    inc(7,1) = -1
+    inc(7,2) = 0
+    inc(8,1) = -1
+    inc(8,2) = -1
+    !
+    !
+    !  Get the outflows and determine for each point to which outflow point it belong 
+    !
+    nbout = 0
+    trip_flow(:,:,:) = 0
+    DO ip=1,nbi
+       DO jp=1,nbj
+          IF ( trip(ip,jp) .GT. 9) THEN
+             nbout = nbout + 1
+             outflow(nbout,1) = ip
+             outflow(nbout,2) = jp
+          ENDIF 
+          IF ( trip(ip,jp) .GT. 0) THEN
+             trip_flow(ip,jp,1) = ip
+             trip_flow(ip,jp,2) = jp
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! Follow the flow of the water
+    !
+    DO ip=1,nbi
+       DO jp=1,nbj
+          IF ( (trip_flow(ip,jp,1) + trip_flow(ip,jp,2)) .GT. 0) THEN
+             trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
+             cnt = 0
+             DO WHILE ( trp .GT. 0 .AND. trp .LT. 9 .AND. cnt .LT. nbi*nbj) 
+                cnt = cnt + 1
+                trip_flow(ip,jp,1) = trip_flow(ip,jp,1) + inc(trp,1)
+                trip_flow(ip,jp,2) = trip_flow(ip,jp,2) + inc(trp,2)
+                trp = trip(trip_flow(ip,jp,1), trip_flow(ip,jp,2))
+             ENDDO
+             IF ( cnt .EQ. nbi*nbj) THEN
+                WRITE(numout,*) 'We could not route point (routing_findrout) :', ip, jp
+                WRITE(numout,*) '-------------> trip '
+                WRITE(fmt,"('(',I3,'I6)')") nbi
+                DO ib=1,nbj
+                   WRITE(numout,fmt) trip(1:nbi,ib)
+                ENDDO
+                STOP
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    !  What is the size of the region behind each outflow point ?
+    !
+    totsz = 0
+    DO ip=1,nbout
+       outsz(ip) = COUNT(trip_flow(:,:,1) .EQ. outflow(ip,1) .AND. trip_flow(:,:,2) .EQ. outflow(ip,2))
+       totsz = totsz + outsz(ip)
+    ENDDO
+    IF ( basin_sz .NE. totsz) THEN
+       WRITE(numout,*) 'Water got lost while I tried to follow it '
+       WRITE(numout,*) basin_sz, totsz
+       WRITE(numout,*) 'Basin id :', basinid
+       DO ip=1,nbout
+          WRITE(numout,*) 'ip :', ip, ' outsz :', outsz(ip), ' outflow :', outflow(ip,1), outflow(ip,2)
+       ENDDO
+       WRITE(numout,*) '-------------> trip '
+       WRITE(fmt,"('(',I3,'I6)')") nbi
+       DO jp=1,nbj
+          WRITE(numout,fmt) trip(1:nbi,jp)
+       ENDDO
+       STOP
+    ENDIF
+    !
+  END SUBROUTINE routing_findrout
+  !
+  !----------------------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_globalize(nbpt, ib, neighbours, area_bx, trip_bx, hierarchy_bx, topoind_bx, min_topoind,&
+       & nb_basin, basin_inbxid, basin_sz, basin_pts, basin_bxout, coast_pts, nwbas, basin_count,&
+       & basin_area, basin_hierarchy, basin_topoind, basin_id, basin_flowdir, outflow_grid,&
+       & nbcoastal, coastal_basin)
+    !
+    IMPLICIT NONE
+    !
+    !  This subroutine will put the basins found for grid-box in in the global map. Connection can
+    !  only be made later when all information is together.
+    !
+    !
+    !  One of the outputs is basin_flowdir. Its convention is 1-8 for the directions from North to North
+    !  West going through South. The negative values will be -3 for return flow, -2 for coastal flow
+    !  and -1 river flow.
+    !
+    !  LOCAL
+    ! 
+    INTEGER(i_std), INTENT (in)               :: nbpt, ib            ! Current grid-box
+    INTEGER(i_std), INTENT(in)                :: neighbours(nbpt,8)  ! Vector of neighbours for each grid point 
+                                                                    ! (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), DIMENSION(nbvmax,nbvmax)     :: area_bx             ! Area of each small box in the grid-box
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax)  :: trip_bx             ! The trip field for each of the smaler boxes
+    REAL(r_std), DIMENSION(nbvmax,nbvmax)     :: hierarchy_bx        ! level in the basin of the point
+    REAL(r_std), DIMENSION(nbvmax,nbvmax)     :: topoind_bx          ! Topographic index
+    REAL(r_std)                               :: min_topoind        ! The default topographic index
+    INTEGER(i_std)                            :: nb_basin            ! number of sub-basins
+    INTEGER(i_std), DIMENSION(nbvmax)         :: basin_inbxid, basin_sz ! ID of basin, number of points in the basin
+    INTEGER(i_std), DIMENSION(nbvmax,nbvmax,2):: basin_pts           ! Points in each basin
+    INTEGER(i_std), DIMENSION(nbvmax)         :: basin_bxout         ! outflow direction
+    INTEGER(i_std)                            :: coast_pts(nbvmax)   ! The coastal flow points
+    ! global maps
+    INTEGER(i_std)                            :: nwbas
+    INTEGER(i_std), DIMENSION(nbpt)           :: basin_count
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)     :: basin_id, basin_flowdir
+    REAL(r_std), DIMENSION(nbpt,nwbas)        :: basin_area, basin_hierarchy, basin_topoind
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)     :: outflow_grid
+    INTEGER(i_std), DIMENSION(nbpt)           :: nbcoastal
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)     :: coastal_basin
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std)      :: ij, iz
+    CHARACTER(LEN=4)   :: hierar_method = 'OUTP'
+    !
+    !
+    DO ij=1, nb_basin
+       !
+       ! Count the basins and keep their ID
+       !
+       basin_count(ib) = basin_count(ib)+1
+       if (basin_count(ib) > nwbas) then 
+          WRITE(numout,*) 'ib=',ib
+          call ipslerr(3,'routing_globalize', &
+               &      'Problem with basin_count : ', & 
+               &      'It is greater than number of allocated basin nwbas.', &
+               &      '(stop to count basins)')
+       endif 
+       basin_id(ib,basin_count(ib)) = basin_inbxid(ij)
+       !
+       ! Transfer the list of basins which flow into the ocean as coastal flow.
+       !
+       IF ( basin_id(ib,basin_count(ib)) .LT. 0) THEN
+          nbcoastal(ib) = basin_sz(ij)
+          coastal_basin(ib,1:nbcoastal(ib)) = coast_pts(1:nbcoastal(ib))
+       ENDIF
+       !
+       !
+       ! Compute the area of the basin
+       !
+       basin_area(ib,ij) = zero
+       basin_hierarchy(ib,ij) = zero
+       !
+       SELECT CASE (hierar_method)
+          !
+          CASE("MINI")
+             basin_hierarchy(ib,ij) = undef_sechiba
+          !
+       END SELECT
+       basin_topoind(ib,ij) = zero
+       !
+       DO iz=1,basin_sz(ij)
+          basin_area(ib,ij) = basin_area(ib,ij) + area_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
+          basin_topoind(ib,ij) = basin_topoind(ib,ij) + topoind_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
+          !
+          ! There are a number of ways to determine the hierarchy of the entire basin.
+          ! We allow for three here :
+          !     - Take the mean value
+          !     - Take the minimum value within the basin
+          !     - Take the value at the outflow point
+          ! Probably taking the value of the outflow point is the best solution.
+          !
+          SELECT CASE (hierar_method)
+             !
+             CASE("MEAN")
+                ! Mean hierarchy of the basin
+                basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij) + &
+                     & hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
+             CASE("MINI")
+                ! The smalest value of the basin
+                IF ( hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .LT. basin_hierarchy(ib,ij)) THEN
+                   basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
+                ENDIF
+             CASE("OUTP")
+                ! Value at the outflow point
+                IF ( trip_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2)) .GT. 100 ) THEN
+                   basin_hierarchy(ib,ij) = hierarchy_bx(basin_pts(ij,iz,1),basin_pts(ij,iz,2))
+                ENDIF
+             CASE DEFAULT
+                WRITE(numout,*) 'Unknown method for computing the hierarchy of the basin'
+                STOP 'routing_globalize'
+          END SELECT
+          !
+       ENDDO
+       !
+       basin_topoind(ib,ij) = basin_topoind(ib,ij)/REAL(basin_sz(ij),r_std)
+       !
+       SELECT CASE (hierar_method)
+          !
+          CASE("MEAN")
+             basin_hierarchy(ib,ij) = basin_hierarchy(ib,ij)/REAL(basin_sz(ij),r_std)
+          !
+       END SELECT
+       !
+       ! To make sure that it has the lowest number if this is an outflow point we reset  basin_hierarchy
+       !
+       IF (basin_bxout(ij) .LT. 0) THEN
+          basin_hierarchy(ib,ij) = min_topoind
+          basin_topoind(ib,ij) = min_topoind
+       ENDIF
+       !
+       !
+       ! Keep the outflow boxes and basin
+       !
+       basin_flowdir(ib,ij) = basin_bxout(ij)
+       IF (basin_bxout(ij) .GT. 0) THEN
+          outflow_grid(ib,ij) = neighbours(ib,basin_bxout(ij))
+       ELSE
+          outflow_grid(ib,ij) = basin_bxout(ij)
+       ENDIF
+       !
+       !
+    ENDDO
+    !
+
+    !
+  END SUBROUTINE routing_globalize
+  !
+  !-----------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_linkup(nbpt, neighbours, nwbas, basin_count, basin_area, basin_id, basin_flowdir, &
+       & basin_hierarchy, outflow_grid, outflow_basin, inflow_number, inflow_grid, inflow_basin, nbcoastal,&
+       & coastal_basin, invented_basins)
+    !
+    IMPLICIT NONE
+    !
+    ! This subroutine will make the connections between the basins and ensure global coherence.
+    !
+    ! The convention for outflow_grid is :
+    !  outflow_grid = -1 : River flow
+    !  outflow_grid = -2 : Coastal flow
+    !  outflow_grid = -3 : Return flow
+    !
+    !
+    ! INPUT
+    !
+    INTEGER(i_std), INTENT (in)                    :: nbpt
+    INTEGER(i_std), DIMENSION(nbpt,8), INTENT (in) :: neighbours
+    !
+    INTEGER(i_std)                                 :: nwbas
+    INTEGER(i_std), DIMENSION(nbpt)                :: basin_count
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: basin_id
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: basin_flowdir
+    REAL(r_std), DIMENSION(nbpt,nwbas)             :: basin_area, basin_hierarchy
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: outflow_grid
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: outflow_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: inflow_number
+    INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax)    :: inflow_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas,nbvmax)    :: inflow_grid
+    INTEGER(i_std), DIMENSION(nbpt)                :: nbcoastal
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: coastal_basin
+    REAL(r_std), INTENT(in)                        :: invented_basins
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std) :: sp, sb, sbl, inp, bid, outdm1, outdp1
+    INTEGER(i_std) :: dp1, dm1, dm1i, dp1i, bp1, bm1
+    INTEGER(i_std) :: dop, bop
+    INTEGER(i_std) :: fbas(nwbas), nbfbas
+    REAL(r_std)    :: fbas_hierarchy(nwbas)
+    INTEGER(i_std) :: ff(1)
+    !
+    ! WARNING
+    LOGICAL, PARAMETER :: check = .FALSE.
+    ! ERRORS 
+    LOGICAL :: error1, error2, error3, error4, error5
+    
+    error1=.FALSE.
+    error2=.FALSE.
+    error3=.FALSE.
+    error4=.FALSE.
+    error5=.FALSE.
+
+    outflow_basin(:,:) = undef_int
+    inflow_number(:,:) = 0
+    !
+    DO sp=1,nbpt
+       DO sb=1,basin_count(sp)
+          !
+          inp = outflow_grid(sp,sb)
+          bid = basin_id(sp,sb)
+          !
+          ! We only work on this point if it does not flow into the ocean
+          ! At this point any of the outflows is designated by a negative values in
+          ! outflow_grid
+          !
+          IF ( inp .GT. 0 ) THEN
+             !
+             ! Now find the basin in the onflow point (inp)
+             !
+             nbfbas = 0
+             !
+             !
+             DO sbl=1,basin_count(inp)
+                !
+                ! Either it is a standard basin or one aggregated from ocean flow points.
+                ! If we flow into a another grid box we have to make sure that its hierarchy in the
+                ! basin is lower.
+                !
+                !
+                IF ( basin_id(inp,sbl) .GT. 0 ) THEN
+                   IF ( basin_id(inp,sbl) .EQ. bid .OR. basin_id(inp,sbl) .GT. invented_basins) THEN
+                      nbfbas =nbfbas + 1
+                      fbas(nbfbas) = sbl
+                      fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
+                   ENDIF
+                ELSE
+                   IF ( COUNT(coastal_basin(inp,1:nbcoastal(inp)) .EQ. bid) .GT. 0 ) THEN
+                      nbfbas =nbfbas + 1
+                      fbas(nbfbas) = sbl
+                      fbas_hierarchy(nbfbas) = basin_hierarchy(inp,sbl)
+                   ENDIF
+                ENDIF
+                !
+             ENDDO
+             ! 
+             !  If we have more than one basin we will take the one which is lowest
+             !  in the hierarchy.
+             !
+             IF (nbfbas .GE. 1) THEN
+                ff = MINLOC(fbas_hierarchy(1:nbfbas))
+                sbl = fbas(ff(1))
+                !
+                bop = undef_int
+                IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
+                   IF ( basin_hierarchy(inp,sbl) .LE. basin_hierarchy(sp,sb) ) THEN
+                      bop = sbl
+                   ELSE
+                      ! The same hierarchy is allowed if both grids flow in about 
+                      ! the same direction :
+                      IF ( ( MOD(basin_flowdir(inp,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
+                           & ( basin_flowdir(inp,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
+                           & ( MOD(basin_flowdir(inp,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
+                         bop = sbl
+                      ENDIF
+                   ENDIF
+                ENDIF
+                !
+                ! If the basin is suitable (bop < undef_int) then take it
+                !
+                IF ( bop .LT. undef_int ) THEN
+                   outflow_basin(sp,sb) = bop
+                   inflow_number(inp,bop) =  inflow_number(inp,bop) + 1
+                   IF ( inflow_number(inp,bop) .LE. nbvmax ) THEN
+                      inflow_grid(inp, bop, inflow_number(inp,bop)) = sp
+                      inflow_basin(inp, bop, inflow_number(inp,bop)) = sb
+                   ELSE
+                      error1=.TRUE.
+                      EXIT
+                   ENDIF
+                ENDIF
+             ENDIF
+             !
+             !
+          ENDIF
+          !
+          !
+          !
+          ! Did we find it ?
+          !
+          ! In case the outflow point was ocean or we did not find the correct basin we start to look
+          ! around. We find two options for the outflow direction (dp1 & dm1) and the corresponding 
+          ! basin index (bp1 & bm1).
+          !
+          !
+          IF ( outflow_basin(sp,sb) .EQ. undef_int &
+               & .AND. basin_flowdir(sp,sb) .GT. 0) THEN
+             !
+             dp1i = MOD(basin_flowdir(sp,sb)+1-1, 8)+1
+             dp1 = neighbours(sp,dp1i)
+             dm1i = MOD(basin_flowdir(sp,sb)+7-1, 8)+1
+             IF ( dm1i .LT. 1 ) dm1i = 8
+             dm1 = neighbours(sp,dm1i)
+             !
+             !
+             bp1 = -1
+             IF ( dp1 .GT. 0 ) THEN
+                DO sbl=1,basin_count(dp1)
+                   IF (basin_id(dp1,sbl) .EQ. bid .AND.&
+                        & basin_hierarchy(sp,sb) .GE. basin_hierarchy(dp1,sbl) .AND. &
+                        & bp1 .LT. 0) THEN
+                      IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dp1,sbl) ) THEN
+                         bp1 = sbl
+                      ELSE
+                         ! The same hierarchy is allowed if both grids flow in about 
+                         ! the same direction :
+                         IF ( ( MOD(basin_flowdir(dp1,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)).OR. &
+                            & ( basin_flowdir(dp1,sbl) .EQ. basin_flowdir(sp,sb)).OR. &
+                            & ( MOD(basin_flowdir(dp1,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
+                            bp1 = sbl
+                         ENDIF
+                      ENDIF
+                   ENDIF
+                ENDDO
+             ENDIF
+             !
+             bm1 = -1
+             IF ( dm1 .GT. 0 ) THEN
+                DO sbl=1,basin_count(dm1)
+                   IF (basin_id(dm1,sbl) .EQ. bid .AND.&
+                        & basin_hierarchy(sp,sb) .GE. basin_hierarchy(dm1,sbl) .AND. &
+                        & bm1 .LT. 0) THEN
+                      IF ( basin_hierarchy(sp,sb) .GT. basin_hierarchy(dm1,sbl) ) THEN
+                         bm1 = sbl
+                      ELSE                         
+                         ! The same hierarchy is allowed if both grids flow in about 
+                         ! the same direction :
+                         IF ( ( MOD(basin_flowdir(dm1,sbl)+1-1, 8)+1 .EQ. basin_flowdir(sp,sb)) .OR. &
+                            & ( basin_flowdir(dm1,sbl) .EQ. basin_flowdir(sp,sb)) .OR. &
+                            & ( MOD(basin_flowdir(dm1,sbl)+7-1, 8)+1 .EQ. basin_flowdir(sp,sb)) ) THEN
+                            bm1 = sbl
+                         ENDIF
+                      ENDIF
+                   ENDIF
+                ENDDO
+             ENDIF
+             !
+             !
+             ! First deal with the case on land.
+             !
+             ! For that we need to check if the water will be able to flow out of the grid dp1 or dm1 
+             ! and not return to our current grid. If it is the current grid
+             ! then we can not do anything with that neighbour. Thus we set the
+             ! value of outdm1 and outdp1 back to -1
+             !
+             outdp1 = undef_int
+             IF ( dp1 .GT. 0 .AND. bp1 .GT. 0 ) THEN
+                ! if the outflow is into the ocean then we put something less than undef_int in outdp1!
+                IF (basin_flowdir(dp1,bp1) .GT. 0) THEN
+                   outdp1 = neighbours(dp1,basin_flowdir(dp1,bp1))
+                   IF ( outdp1 .EQ. sp ) outdp1 = undef_int 
+                ELSE
+                   outdp1 = nbpt + 1
+                ENDIF
+             ENDIF
+             outdm1 = undef_int
+             IF ( dm1 .GT. 0 .AND. bm1 .GT. 0 ) THEN
+                IF (basin_flowdir(dm1,bm1) .GT. 0) THEN
+                   outdm1 = neighbours(dm1,basin_flowdir(dm1,bm1))
+                   IF ( outdm1 .EQ. sp )  outdm1 = undef_int
+                ELSE
+                   outdm1 = nbpt + 1
+                ENDIF
+             ENDIF
+             !
+             ! Now that we know our options we need go through them.
+             !
+             dop = undef_int
+             bop = undef_int
+             IF ( outdp1 .LT. undef_int .AND. outdm1 .LT. undef_int) THEN
+                ! 
+                ! In this case we let the current basin flow into the smaller one
+                !
+                IF ( basin_area(dp1,bp1) .LT.  basin_area(dm1,bm1) ) THEN
+                   dop = dp1
+                   bop = bp1
+                ELSE
+                   dop = dm1
+                   bop = bm1
+                ENDIF
+                !
+                !
+             ELSE IF (  outdp1 .LT. undef_int ) THEN
+                ! If only the first one is possible
+                dop = dp1
+                bop = bp1
+             ELSE IF ( outdm1 .LT. undef_int ) THEN
+                ! If only the second one is possible
+                dop = dm1
+                bop = bm1
+             ELSE
+                !
+                ! Now we are at the point where none of the neighboring points is suitable 
+                ! or we have a coastal point.
+                !
+                ! If there is an option to put the water into the ocean go for it.
+                !
+                IF ( outflow_grid(sp,sb) .LT. 0 .OR. dm1 .LT. 0 .OR. dp1 .LT. 0 ) THEN
+                   dop = -1
+                ELSE
+                   !
+                   ! If we are on a land point with only land neighbors but no one suitable to let the 
+                   ! water flow into we have to look for a solution in the current grid box.
+                   ! 
+                   !
+                   IF ( bp1 .LT. 0 .AND. bm1 .LT. 0 ) THEN
+                      !
+                      ! Do we have more than one basin with the same ID ?
+                      !
+                      IF ( COUNT(basin_id(sp,1:basin_count(sp)) .EQ. bid) .GE. 2) THEN
+                         !
+                         ! Now we can try the option of flowing into the basin of the same grid box.
+                         !
+                         DO sbl=1,basin_count(sp)
+                            IF (sbl .NE. sb .AND. basin_id(sp,sbl) .EQ. bid) THEN
+                               ! In case this basin has a lower hierarchy or flows into a totaly
+                               ! different direction we go for it.
+                               IF ( (basin_hierarchy(sp,sb) .GE. basin_hierarchy(sp,sbl)) .OR. &
+                                    & (basin_flowdir(sp,sbl) .LT. dm1i .AND.&
+                                    & basin_flowdir(sp,sbl) .GT. dp1i) ) THEN
+                                  dop = sp
+                                  bop = sbl
+                                  IF (check) THEN
+                                     IF (basin_hierarchy(sp,sb) .LT. basin_hierarchy(sp,sbl)) THEN
+                                        WRITE(numout,*) '>>>>>>> POINT CORRECTED against hierarchy :',&
+                                             & sp, sb, 'into', sbl
+                                     ENDIF
+                                  ENDIF
+                               ENDIF
+                               !
+                            ENDIF
+                         ENDDO
+                         !
+                      ENDIF
+                   ENDIF
+                ENDIF
+                !
+                IF ( dop .EQ. undef_int .AND. bop .EQ. undef_int ) THEN
+                   IF (check) THEN
+                      WRITE(numout,*) 'Why are we here with point ', sp, sb
+                      WRITE(numout,*) 'Coodinates : (lon,lat) = ', lalo(sp,2), lalo(sp,1)
+                      WRITE(numout,*) 'Contfrac : = ', contfrac(sp)
+                      WRITE(numout,*) 'Local Basin ID :', basin_id(sp,1:basin_count(sp))
+                      WRITE(numout,*) 'Local hierarchies :', basin_hierarchy(sp,1:basin_count(sp))
+                      WRITE(numout,*) 'Local basin_flowdir :', basin_flowdir(sp,1:basin_count(sp))
+                      WRITE(numout,*) 'Local outflowgrid :', outflow_grid(sp,1:basin_count(sp))
+                      WRITE(numout,*) 'outflow_grid :', inp
+                      WRITE(numout,*) 'Coodinates outflow : (lon,lat) = ', lalo(inp,2), lalo(inp,1)
+                      WRITE(numout,*) 'Contfrac : = ', contfrac(inp)
+                      WRITE(numout,*) 'Outflow Basin ID :', basin_id(inp,1:basin_count(inp))
+                      WRITE(numout,*) 'Outflow hierarchies :', basin_hierarchy(inp,1:basin_count(inp))
+                      WRITE(numout,*) 'Outflow basin_flowdir :', basin_flowdir(inp,1:basin_count(inp))
+                      WRITE(numout,*) 'Explored options +1 :', dp1, bp1, outdp1
+                      WRITE(numout,*) 'Explored +1 Basin ID :', basin_id(dp1,1:basin_count(dp1))
+                      WRITE(numout,*) 'Explored +1 hierarchies :', basin_hierarchy(dp1,1:basin_count(dp1))
+                      WRITE(numout,*) 'Explored +1 basin_flowdir :', basin_flowdir(dp1,1:basin_count(dp1))
+                      WRITE(numout,*) 'Explored options -1 :', dm1, bm1, outdm1
+                      WRITE(numout,*) 'Explored -1 Basin ID :', basin_id(dm1,1:basin_count(dm1))
+                      WRITE(numout,*) 'Explored -1 hierarchies :', basin_hierarchy(dm1,1:basin_count(dm1))
+                      WRITE(numout,*) 'Explored -1 basin_flowdir :', basin_flowdir(dm1,1:basin_count(dm1))
+                      WRITE(numout,*) '****************************'
+                   ENDIF
+                   IF ( contfrac(sp) > 0.01 ) THEN
+                      error2=.TRUE.
+                      EXIT
+                   ENDIF
+                ENDIF
+                !
+             ENDIF
+             !
+             ! Now that we know where we want the water to flow to we write the
+             ! the information in the right fields.
+             !
+             IF ( dop .GT. 0 .AND. dop .NE. undef_int ) THEN
+                outflow_grid(sp,sb) = dop
+                outflow_basin(sp,sb) = bop
+                inflow_number(dop,bop) =  inflow_number(dop,bop) + 1
+                IF ( inflow_number(dop,bop) .LE. nbvmax ) THEN
+                   inflow_grid(dop, bop, inflow_number(dop,bop)) = sp
+                   inflow_basin(dop, bop, inflow_number(dop,bop)) = sb
+                ELSE
+                   error3=.TRUE.
+                   EXIT
+                ENDIF
+                !
+             ELSE
+                outflow_grid(sp,sb) = -2
+                outflow_basin(sp,sb) = undef_int
+             ENDIF
+             !
+          ENDIF
+          !
+          !
+          ! If we still have not found anything then we have to check that there is not a basin
+          ! within the same grid box which has a lower hierarchy.
+          !
+          !
+          IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
+               & .AND. basin_flowdir(sp,sb) .GT. 0) THEN
+             !
+             
+             IF (check) &
+                  WRITE(numout,*) 'There is no reason to here, this part of the code should be dead :', sp,sb
+             !
+             DO sbl=1,basin_count(sp)
+                !
+                ! Three conditons are needed to let the water flow into another basin of the
+                ! same grid :
+                ! - another basin than the current one
+                ! - same ID
+                ! - of lower hierarchy.
+                !
+                IF ( (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid)&
+                     & .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl)) ) THEN
+                   outflow_basin(sp,sb) = sbl
+                   inflow_number(sp,sbl) =  inflow_number(sp,sbl) + 1
+                   IF ( inflow_number(sp,sbl) .LE. nbvmax ) THEN
+                      IF ( sp .EQ. 42 .AND. sbl .EQ. 1) THEN
+                         IF (check) &
+                              WRITE(numout,*) 'ADD INFLOW (3):', sp, sb
+                      ENDIF
+                      inflow_grid(sp, sbl, inflow_number(sp,sbl)) = sp
+                      inflow_basin(sp, sbl, inflow_number(sp,sbl)) = sb
+                   ELSE
+                      error4=.TRUE.
+                      EXIT
+                   ENDIF
+                ENDIF
+             ENDDO
+          ENDIF
+          !
+          ! Ok that is it, we give up :-)
+          !
+          IF ( outflow_grid(sp,sb) .GT. 0 .AND. outflow_basin(sp,sb) .EQ. undef_int &
+               & .AND. basin_flowdir(sp,sb) .GT. 0) THEN
+             !
+             error5=.TRUE.
+             EXIT
+          ENDIF
+       ENDDO
+       !
+    ENDDO
+    IF (error1) THEN
+       WRITE(numout,*) " routing_linkup : bop .LT. undef_int",bop
+       CALL ipslerr(3,'routing_linkup', &
+            "bop .LT. undef_int",'Increase nbvmax','stop routing_linkup')
+    ENDIF
+    IF (error2) THEN
+       CALL ipslerr(3,'routing_linkup', &
+            &      'In the routine which make connections between the basins and ensure global coherence,', & 
+            &      'there is a problem with outflow linkup without any valid direction. Try with check=.TRUE.', &
+            &      '(Perhaps there is a problem with the grid.)')
+    ENDIF
+    IF (error3) THEN
+       WRITE(numout,*) " routing_linkup : dop .GT. 0 .AND. dop .NE. undef_int",dop
+       CALL ipslerr(3,'routing_linkup', &
+            "dop .GT. 0 .AND. dop .NE. undef_int",'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
+    ENDIF
+    IF (error4) THEN
+       WRITE(numout,*) " routing_linkup : (sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) ", & 
+            &  " .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))",sbl,sb,basin_id(sp,sbl),bid, & 
+            &  basin_hierarchy(sp,sb),basin_hierarchy(sp,sbl)
+       CALL ipslerr(3,'routing_linkup', &
+            "(sbl .NE. sb) .AND. (basin_id(sp,sbl) .EQ. bid) .AND. (basin_hierarchy(sp,sb) .GT. basin_hierarchy(sp,sbl))" &
+            ,'Increase nbvmax. Try with check=.TRUE.','stop routing_linkup')
+    ENDIF
+    IF (error5) THEN
+       WRITE(numout,*) 'We could not find the basin into which we need to flow'
+       WRITE(numout,*) 'Grid point ', sp, ' and basin ', sb
+       WRITE(numout,*) 'Explored neighbours :', dm1, dp1 
+       WRITE(numout,*) 'Outflow direction :', basin_flowdir(sp,sb)
+       WRITE(numout,*) 'Outlfow grid :', outflow_grid(sp,sb)
+       WRITE(numout,*) 'Outlfow basin :',outflow_basin(sp,sb)
+       WRITE(numout,*) 'basin ID:',basin_id(sp,sb)
+       WRITE(numout,*) 'Hierarchy :', basin_hierarchy(sp,sb)
+       CALL ipslerr(3,'routing_linkup', &
+            "We could not find the basin into which we need to flow",'Try with check=.TRUE.','stop routing_linkup')
+    ENDIF
+    !
+    ! Check for each outflow basin that it exists
+    !
+    DO sp=1,nbpt
+       DO sb=1,basin_count(sp)
+          !
+          inp = outflow_grid(sp,sb)
+          sbl = outflow_basin(sp,sb)
+          IF ( inp .GE. 0 ) THEN
+             IF ( basin_count(inp) .LT. sbl ) THEN
+                WRITE(numout,*) 'point :', sp, ' basin :', sb
+                WRITE(numout,*) 'Flows into point :', inp, ' basin :', sbl
+                WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(inp)
+                STOP
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+  END SUBROUTINE routing_linkup
+  !
+  !---------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_fetch(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_id,&
+       & outflow_grid, outflow_basin, fetch_basin)
+    !
+    IMPLICIT NONE
+    !
+    ! This subroutine will compute the fetch of each basin. This means that for each basin we
+    ! will know how much area is upstream. It will help decide how to procede with the
+    ! the truncation later and allow to set correctly in outflow_grid the distinction
+    ! between coastal and river flow
+    !
+    !
+    ! INPUT
+    !
+    INTEGER(i_std), INTENT(in)                             :: nbpt
+    !
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)             :: resolution
+    REAL(r_std), DIMENSION(nbpt), INTENT(in)               :: contfrac    ! Fraction of land in each grid box
+    !
+    INTEGER(i_std)                                         :: nwbas
+    INTEGER(i_std), DIMENSION(nbpt), INTENT(in)            :: basin_count
+    REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(inout)      :: basin_area
+    INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in)      :: basin_id
+    INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(inout)   :: outflow_grid
+    INTEGER(i_std), DIMENSION(nbpt,nwbas), INTENT(in)      :: outflow_basin
+    REAL(r_std), DIMENSION(nbpt,nwbas), INTENT(out)        :: fetch_basin
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std) :: ib, ij, ff(1), it, itt, igrif, ibasf, nboutflow
+    REAL(r_std)    :: contarea, totbasins
+    REAL(r_std), DIMENSION(nbpt*nbvmax) :: tmp_area
+    INTEGER(i_std), DIMENSION(nbpt*nbvmax,2) :: tmpindex
+    !
+    !
+    ! Normalize the area of all basins
+    !
+    DO ib=1,nbpt
+       !
+       totbasins = SUM(basin_area(ib,1:basin_count(ib)))
+       contarea = resolution(ib,1)*resolution(ib,2)*contfrac(ib)
+       !
+       DO ij=1,basin_count(ib)
+          basin_area(ib,ij) = basin_area(ib,ij)/totbasins*contarea
+       ENDDO
+       !
+    ENDDO
+    WRITE(numout,*) 'Normalization done'
+    !
+    ! Compute the area upstream of each basin
+    !
+    fetch_basin(:,:) = zero
+    !
+    !
+    DO ib=1,nbpt
+       !
+       DO ij=1,basin_count(ib)
+          !
+          fetch_basin(ib, ij) = fetch_basin(ib, ij) + basin_area(ib,ij)
+          !
+          igrif = outflow_grid(ib,ij)
+          ibasf = outflow_basin(ib,ij)
+          !
+          itt = 0
+          DO WHILE (igrif .GT. 0)
+             fetch_basin(igrif,ibasf) =  fetch_basin(igrif,ibasf) + basin_area(ib, ij)
+             it = outflow_grid(igrif, ibasf)
+             ibasf = outflow_basin(igrif, ibasf)
+             igrif = it
+             itt = itt + 1
+             IF ( itt .GT. 500) THEN
+                WRITE(numout,&
+                     "('Grid ',I5, ' and basin ',I5, 'did not converge after iteration ',I5)") ib, ij, itt
+                WRITE(numout,*) 'Basin ID :', basin_id(igrif,ibasf)
+                WRITE(numout,&
+                     "('We are stuck with the flow into grid ',I5,' and basin ',I5)") igrif, ibasf
+                IF ( itt .GT. 510) THEN
+                   STOP ' routing_fetch'
+                ENDIF
+             ENDIF
+          ENDDO
+          !
+       ENDDO
+       !
+    ENDDO
+    !
+    WRITE(numout,*) 'The smalest FETCH :', MINVAL(fetch_basin)
+    WRITE(numout,*) 'The largest FETCH :', MAXVAL(fetch_basin)
+    !
+    ! Now we set for the 'num_largest' largest basins the outflow condition as stream flow 
+    ! (i.e. outflow_grid = -1) and all other outflow basins are set to coastal flow 
+    ! (i.e. outflow_grid = -2). The return flow is not touched.
+    !
+    nboutflow = 0
+    !
+    DO ib=1,nbpt
+       !
+       DO ij=1,basin_count(ib)
+          !
+          ! We do not need any more the river flow flag as we are going to reset it.
+          !
+          IF ( outflow_grid(ib,ij) .EQ. -1) THEN
+             outflow_grid(ib,ij) = -2
+          ENDIF
+          !
+          IF ( outflow_grid(ib,ij) .EQ. -2) THEN
+             !
+             nboutflow = nboutflow + 1
+             tmp_area(nboutflow) = fetch_basin(ib,ij)
+             tmpindex(nboutflow,1) = ib
+             tmpindex(nboutflow,2) = ij
+             !
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    DO ib=1, num_largest
+       ff = MAXLOC(tmp_area(1:nboutflow))
+       outflow_grid(tmpindex(ff(1),1), tmpindex(ff(1),2)) = -1
+       tmp_area(ff(1)) = zero
+    ENDDO
+    !
+  END SUBROUTINE routing_fetch
+  !
+  !---------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_truncate(nbpt, resolution, contfrac, nwbas, basin_count, basin_area, basin_topoind,&
+       & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
+       & inflow_grid, inflow_basin)
+    !
+    IMPLICIT NONE
+    !
+    !
+    ! This subroutine reduces the number of basins per gird to the value chosen by the user.
+    ! it also computes the final field which will be used to route the water at the
+    ! requested truncation.
+    !
+    ! INPUT
+    !
+    INTEGER(i_std)                                   :: nbpt
+    !
+    REAL(r_std), DIMENSION(nbpt,2)                   :: resolution
+    REAL(r_std), DIMENSION(nbpt), INTENT(in)         :: contfrac    ! Fraction of land in each grid box
+    !
+    INTEGER(i_std)                                   :: nwbas
+    INTEGER(i_std), DIMENSION(nbpt)                  :: basin_count
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)            :: basin_id
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)            :: basin_flowdir
+    REAL(r_std), DIMENSION(nbpt,nwbas)               :: basin_area
+    REAL(r_std), DIMENSION(nbpt,nwbas)               :: basin_topoind
+    REAL(r_std), DIMENSION(nbpt,nwbas)               :: fetch_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)            :: outflow_grid
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)            :: outflow_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)            :: inflow_number
+    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas)      :: inflow_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas)      :: inflow_grid
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std), PARAMETER :: pickmax = 200
+    INTEGER(i_std) :: ib, ij, ibf, ijf, igrif, ibasf, cnt, pold, bold, ff(2)
+    INTEGER(i_std) :: ii, kbas, sbas, ik, iter, ibt, obj
+    REAL(r_std), DIMENSION(nbpt,nbasmax) :: floflo
+    REAL(r_std), DIMENSION(nbpt)   :: gridarea, gridbasinarea
+    REAL(r_std)                    :: ratio
+    INTEGER(i_std), DIMENSION(pickmax,2) :: largest_basins
+    INTEGER(i_std), DIMENSION(pickmax) :: tmp_ids
+    INTEGER(i_std) :: multbas, iml(1)
+    INTEGER(i_std), DIMENSION(pickmax) :: multbas_sz
+    REAL(r_std), DIMENSION(pickmax) :: tmp_area
+    INTEGER(i_std), DIMENSION(pickmax,pickmax) :: multbas_list
+    !
+    INTEGER(i_std) :: nbtruncate
+    INTEGER(i_std), SAVE, ALLOCATABLE, DIMENSION(:) :: indextrunc
+    !
+    IF ( .NOT. ALLOCATED(indextrunc)) THEN
+       ALLOCATE(indextrunc(nbpt))
+    ENDIF
+    !
+    ! Truncate if needed and find the path closest to the high resolution data.
+    !
+    ! The algorithm :
+    ! 
+    ! We only go through this procedure only as many times as there are basins to take out at most.
+    ! This is important as it allows the simplifications to spread from one grid to the other.
+    ! The for each step of the iteration and at each grid point we check the following options for 
+    ! simplifying the pathways of water :
+    ! 1) If the basin of a grid flows into another basin of the same grid. Kill the one which only
+    !    served as a transition
+    ! 2) If in one grid box we have a number of basins which flow into the ocean as coastal flow. 
+    !    We kill the smallest one and put into the largest basin. There is no need to manage many 
+    !    basins going into the ocean as coastal flows. 
+    ! 3) If we have streams run in parallel from one gird box to the others (that is these are 
+    !    different basins) we will put the smaller one in the larger one. This may hapen at any
+    !    level of the flow but in theory it should propagate downstream.
+    ! 4) If we have two basins with the same ID but flow into different grid boxes we sacrifice
+    !    the smallest one and route it through the largest. 
+    !
+    ! Obviously if any of the options find something then we skip the rest and take out the basin.
+    !
+    !
+    ! We have to go through the grid as least as often as we have to reduce the number of basins
+    ! For good measure we add 3 more passages.
+    !
+    !
+    DO iter = 1, MAXVAL(basin_count) - nbasmax +3
+       !
+       ! Get the points over which we wish to truncate
+       !
+       nbtruncate = 0
+       DO ib = 1, nbpt
+          IF ( basin_count(ib) .GT. nbasmax ) THEN
+             nbtruncate = nbtruncate + 1
+             indextrunc(nbtruncate) = ib
+          ENDIF
+       ENDDO
+       !
+       ! Go through the basins which need to be truncated.       
+       !
+       DO ibt=1,nbtruncate
+          !
+          ib = indextrunc(ibt)
+          !
+          ! Check if we have basin which flows into a basin in the same grid
+          ! kbas = basin we will have to kill
+          ! sbas = basin which takes over kbas
+          !
+          kbas = 0
+          sbas = 0
+          !
+          ! 1) Can we find a basin which flows into a basin of the same grid ?
+          !
+          DO ij=1,basin_count(ib)
+             DO ii=1,basin_count(ib)
+                IF ( outflow_grid(ib,ii) .EQ. ib .AND. outflow_basin(ib, ii) .EQ. ij .AND. kbas*sbas .NE. 0) THEN
+                   kbas = ii
+                   sbas = ij
+                ENDIF
+             ENDDO
+          ENDDO
+          !
+          ! 2) Merge two basins which flow into the ocean as coastal or return flow 
+          ! (outflow_grid = -2 or -3). Well obviously only if we have more than 1 and 
+          ! have not found anything yet!
+          !
+          IF ( (COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 .OR.&
+               & COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -3) .GT. 1) .AND.&
+               & kbas*sbas .EQ. 0) THEN
+             !
+             multbas = 0
+             multbas_sz(:) = 0
+             !
+             IF ( COUNT(outflow_grid(ib,1:basin_count(ib)) .EQ. -2) .GT. 1 ) THEN
+                obj = -2
+             ELSE
+                obj = -3
+             ENDIF
+             !
+             ! First we get the list of all basins which go out as coastal or return flow (obj)
+             !
+             DO ij=1,basin_count(ib)
+                IF ( outflow_grid(ib,ij) .EQ. obj ) THEN
+                   multbas = multbas + 1
+                   multbas_sz(multbas) = ij
+                   tmp_area(multbas) = fetch_basin(ib,ij)
+                ENDIF
+             ENDDO
+             !
+             ! Now the take the smalest to be transfered to the largest
+             !
+             iml = MAXLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
+             sbas = multbas_sz(iml(1))
+             iml = MINLOC(tmp_area(1:multbas), MASK = tmp_area(1:multbas) .GT. zero)
+             kbas = multbas_sz(iml(1))
+             !
+          ENDIF
+          !
+          !   3) If we have basins flowing into the same grid but different basins then we put them 
+          !   together. Obviously we first work with the grid which has most streams runing into it
+          !   and puting the smalest in the largests catchments.
+          !
+          IF ( kbas*sbas .EQ. 0) THEN
+             !
+             tmp_ids(1:basin_count(ib)) = outflow_grid(ib,1:basin_count(ib))
+             multbas = 0
+             multbas_sz(:) = 0
+             !
+             ! First obtain the list of basins which flow into the same basin
+             !
+             DO ij=1,basin_count(ib)
+                IF ( outflow_grid(ib,ij) .GT. 0 .AND.&
+                     & COUNT(tmp_ids(1:basin_count(ib)) .EQ. outflow_grid(ib,ij)) .GT. 1) THEN
+                   multbas = multbas + 1
+                   DO ii=1,basin_count(ib)
+                      IF ( tmp_ids(ii) .EQ. outflow_grid(ib,ij)) THEN
+                         multbas_sz(multbas) = multbas_sz(multbas) + 1
+                         multbas_list(multbas,multbas_sz(multbas)) = ii
+                         tmp_ids(ii) = -99
+                      ENDIF
+                   ENDDO
+                ELSE
+                   tmp_ids(ij) = -99
+                ENDIF
+             ENDDO
+             !
+             ! Did we come up with any basins to deal with this way ?
+             !
+             IF ( multbas .GT. 0 ) THEN
+                !
+                iml = MAXLOC(multbas_sz(1:multbas))
+                ik = iml(1)
+                !
+                ! Take the smalest and largest of these basins !
+                !
+                DO ii=1,multbas_sz(ik)
+                   tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
+                ENDDO
+                iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
+                sbas = multbas_list(ik,iml(1))
+                iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
+                kbas = multbas_list(ik,iml(1))
+                !
+             ENDIF
+             !
+          ENDIF
+          !
+          !   4) If we have twice the same basin we put them together even if they flow into different
+          !   directions. If one of them goes to the ocean it takes the advantage.
+          !
+          IF ( kbas*sbas .EQ. 0) THEN
+             !
+             tmp_ids(1:basin_count(ib)) = basin_id(ib,1:basin_count(ib))
+             multbas = 0
+             multbas_sz(:) = 0
+             !
+             ! First obtain the list of basins which have sub-basins in this grid box.
+             ! (these are identified by their IDs)
+             !
+             DO ij=1,basin_count(ib)
+                IF ( COUNT(tmp_ids(1:basin_count(ib)) .EQ. basin_id(ib,ij)) .GT. 1) THEN
+                   multbas = multbas + 1
+                   DO ii=1,basin_count(ib)
+                      IF ( tmp_ids(ii) .EQ. basin_id(ib,ij)) THEN
+                         multbas_sz(multbas) = multbas_sz(multbas) + 1
+                         multbas_list(multbas,multbas_sz(multbas)) = ii
+                         tmp_ids(ii) = -99
+                      ENDIF
+                   ENDDO
+                ELSE
+                   tmp_ids(ij) = -99
+                ENDIF
+             ENDDO
+             !
+             ! We are going to work on the basin with the largest number of sub-basins.
+             ! (IF we have a basin which has subbasins !)
+             !
+             IF ( multbas .GT. 0 ) THEN
+                !
+                iml = MAXLOC(multbas_sz(1:multbas))
+                ik = iml(1)
+                !
+                ! If one of the basins goes to the ocean then it is going to have the priority
+                !
+                tmp_area(:) = zero
+                IF ( COUNT(outflow_grid(ib,multbas_list(ik,1:multbas_sz(ik))) .LT. 0) .GT. 0) THEN
+                   DO ii=1,multbas_sz(ik)
+                      IF ( outflow_grid(ib,multbas_list(ik,ii)) .LT. 0 .AND. sbas .EQ. 0 ) THEN
+                         sbas = multbas_list(ik,ii)
+                      ELSE
+                         tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
+                      ENDIF
+                   ENDDO
+                   ! take the smalest of the subbasins
+                   iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
+                   kbas = multbas_list(ik,iml(1))
+                ELSE
+                   !
+                   ! Else we take simply the largest and smalest
+                   !
+                   DO ii=1,multbas_sz(ik)
+                      tmp_area(ii) = fetch_basin(ib, multbas_list(ik,ii))
+                   ENDDO
+                   iml = MAXLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
+                   sbas = multbas_list(ik,iml(1))
+                   iml = MINLOC(tmp_area(1:multbas_sz(ik)), MASK = tmp_area(1:multbas_sz(ik)) .GT. zero)
+                   kbas = multbas_list(ik,iml(1))
+                   !
+                ENDIF
+                !
+                !
+             ENDIF
+          ENDIF
+          !
+          !
+          !
+          ! Then we call routing_killbas to clean up the basins in this grid
+          !
+          IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
+             CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
+                  & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
+                  & inflow_grid, inflow_basin)
+          ENDIF
+          !
+       ENDDO
+       !
+       !      
+    ENDDO
+    !
+    ! If there are any grids left with too many basins we need to take out the big hammer !
+    ! We will only do it if this represents less than 5% of all points.
+    !
+    IF ( COUNT(basin_count .GT. nbasmax) .GT. 0 ) THEN
+       !
+       !
+       IF ( COUNT(basin_count .GT. nbasmax)/nbpt*100 .GT. 5 ) THEN
+          WRITE(numout,*) 'We have ', COUNT(basin_count .GT. nbasmax)/nbpt*100, '% of all points which do not yet'
+          WRITE(numout,*) 'have the right trunctaction. That is too much to apply a brutal method'
+          DO ib = 1, nbpt
+             IF ( basin_count(ib) .GT. nbasmax ) THEN
+                !
+                WRITE(numout,*) 'We did not find a basin which could be supressed. We will'
+                WRITE(numout,*) 'not be able to reduce the truncation in grid ', ib
+                DO ij=1,basin_count(ib)
+                   WRITE(numout,*) 'grid, basin nb and id :', ib, ij, basin_id(ib,ij)
+                   WRITE(numout,*) 'Outflow grid and basin ->', outflow_grid(ib,ij), outflow_basin(ib, ij)
+                ENDDO
+             ENDIF
+          ENDDO
+          STOP 'routing_truncate'
+          !
+       ELSE
+          !
+          !
+          DO ib = 1,nbpt
+             DO WHILE ( basin_count(ib) .GT. nbasmax )
+                !
+                WRITE(numout,*) 'HAMMER, ib, basin_count :', ib, basin_count(ib)
+                !
+                ! Here we simply put the smallest basins into the largest ones. It is really a brute force
+                ! method but it will only be applied if everything has failed.
+                !
+                DO ii = 1,basin_count(ib)
+                   tmp_area(ii) = fetch_basin(ib, ii)
+                ENDDO
+                !
+                iml = MAXLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
+                sbas =iml(1)
+                iml = MINLOC(tmp_area(1:basin_count(ib)), MASK = tmp_area(1:basin_count(ib)) .GT. 0.)
+                kbas = iml(1)
+                !
+                IF ( kbas .GT. 0 .AND. sbas .GT. 0 ) THEN
+                   CALL routing_killbas(nbpt, ib, kbas, sbas, nwbas, basin_count, basin_area, basin_topoind,&
+                        & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
+                        & inflow_grid, inflow_basin)
+                ENDIF
+             ENDDO
+          ENDDO
+          !
+       ENDIF
+       !
+       !
+    ENDIF
+    !
+    ! Now that we have reached the right truncation (resolution) we will start
+    ! to produce the variables we will use to route the water.
+    !
+    DO ib=1,nbpt
+       !
+       ! For non existing basins the route_tobasin variable is put to zero. This will allow us
+       ! to pick up the number of basin afterwards.
+       !
+       route_togrid(ib,:) = ib
+       route_tobasin(ib,:) = 0
+       routing_area(ib,:) = zero
+       !
+    ENDDO
+    !
+    ! Transfer the info into the definitive variables
+    !
+    DO ib=1,nbpt
+       DO ij=1,basin_count(ib)
+          routing_area(ib,ij) = basin_area(ib,ij)
+          topo_resid(ib,ij) = basin_topoind(ib,ij)
+          global_basinid(ib,ij) = basin_id(ib,ij)
+          route_togrid(ib,ij) = outflow_grid(ib,ij)
+          route_tobasin(ib,ij) = outflow_basin(ib,ij)
+       ENDDO
+    ENDDO
+    !
+    !
+    ! Set the new convention for the outflow conditions
+    ! Now it is based in the outflow basin and the outflow grid will
+    ! be the same as the current.
+    ! returnflow to the grid : nbasmax + 1
+    ! coastal flow           : nbasmax + 2
+    ! river outflow          : nbasmax + 3
+    !
+    ! Here we put everything here in coastal flow. It is later where we will
+    ! put the largest basins into river outflow.
+    !
+    DO ib=1,nbpt
+       DO ij=1,basin_count(ib)
+          ! River flows
+          IF ( route_togrid(ib,ij) .EQ. -1 ) THEN
+             route_tobasin(ib,ij) = nbasmax + 2
+             route_togrid(ib,ij) = ib
+          ! Coastal flows
+          ELSE IF ( route_togrid(ib,ij) .EQ. -2 ) THEN
+             route_tobasin(ib,ij) = nbasmax + 2
+             route_togrid(ib,ij) = ib
+          ! Return flow
+          ELSE IF ( route_togrid(ib,ij) .EQ. -3 ) THEN
+             route_tobasin(ib,ij) = nbasmax + 1
+             route_togrid(ib,ij) = ib
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! A second check on the data. Just make sure that each basin flows somewhere.
+    !
+    DO ib=1,nbpt
+       DO ij=1,basin_count(ib)
+          ibf = route_togrid(ib,ij)
+          ijf = route_tobasin(ib,ij)
+          IF ( ijf .GT. basin_count(ibf) .AND.  ijf .LE. nbasmax) THEN
+             WRITE(numout,*) 'Second check'
+             WRITE(numout,*) 'point :', ib, ' basin :', ij
+             WRITE(numout,*) 'Flows into point :', ibf, ' basin :', ijf
+             WRITE(numout,*) 'But it flows into now here as basin count = ', basin_count(ibf)
+             STOP
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    ! Verify areas of the contienents
+    !
+    floflo(:,:) = zero
+    gridarea(:) = contfrac(:)*resolution(:,1)*resolution(:,2)
+    DO ib=1,nbpt
+       gridbasinarea(ib) = SUM(routing_area(ib,:))
+    ENDDO
+    !
+    DO ib=1,nbpt
+       DO ij=1,basin_count(ib)
+          cnt = 0
+          igrif = ib
+          ibasf = ij
+          DO WHILE (ibasf .LE. nbasmax .AND. cnt .LT. nbasmax*nbpt)
+             cnt = cnt + 1
+             pold = igrif
+             bold = ibasf
+             igrif = route_togrid(pold, bold)
+             ibasf = route_tobasin(pold, bold)
+             IF ( ibasf .GT. basin_count(igrif)  .AND.  ibasf .LE. nbasmax) THEN
+                WRITE(numout,*) 'We should not be here as the basin flows into the pampa'
+                WRITE(numout,*) 'Last correct point :', pold, bold
+                WRITE(numout,*) 'It pointed to in the new variables :', route_togrid(pold, bold),route_tobasin(pold, bold) 
+                WRITE(numout,*) 'The old variables gave :', outflow_grid(pold, bold), outflow_basin(pold, bold) 
+                WRITE(numout,*) 'Where we ended up :', igrif,ibasf
+                STOP
+             ENDIF
+          ENDDO
+          !
+          IF ( ibasf .GT. nbasmax ) THEN
+             floflo(igrif,bold) = floflo(igrif,bold) + routing_area(ib,ij)
+          ELSE
+             WRITE(numout,*) 'The flow did not end up in the ocean or in the grid cell.'
+             WRITE(numout,*) 'For grid ', ib, ' and basin ', ij
+             WRITE(numout,*) 'The last grid was ', igrif, ' and basin ', ibasf
+             STOP 'routing_truncate'
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    DO ib=1,nbpt
+       IF ( gridbasinarea(ib) > zero ) THEN
+          ratio = gridarea(ib)/gridbasinarea(ib)
+          routing_area(ib,:) = routing_area(ib,:)*ratio
+       ENDIF
+    ENDDO
+    !
+    WRITE(numout,*) 'Sum of area of all outflow areas :',SUM(routing_area)
+    WRITE(numout,*) 'Surface of all continents :', SUM(gridarea)
+    !
+    ! Redo the the distinction between river outflow and coastal flow. We can not
+    ! take into account the return flow points.
+    !
+    ibf = 0
+    DO ib=1, pickmax
+       ff = MAXLOC(floflo)
+       IF ( route_tobasin(ff(1), ff(2)) .EQ. nbasmax + 2) THEN
+          ibf = ibf + 1
+          largest_basins(ibf,:) = ff(:)
+       ENDIF
+       floflo(ff(1), ff(2)) = zero
+    ENDDO
+    !
+    ! Put the largest basins into river flows.
+    !
+    IF ( ibf .LT.  num_largest) THEN
+       WRITE(numout,*) 'Not enough basins to choose the ',  num_largest, 'largest'
+       STOP 'routing_truncate'
+    ENDIF
+    !
+    !
+    !
+    DO ib=1, num_largest
+       route_tobasin(largest_basins(ib,1),largest_basins(ib,2)) = nbasmax + 3
+    ENDDO
+    !
+    WRITE(numout,*) 'NUMBER OF RIVERS :', COUNT(route_tobasin .GE. nbasmax + 3)
+    !
+  END SUBROUTINE  routing_truncate
+  !
+  !-------------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_killbas(nbpt, ib, tokill, totakeover, nwbas, basin_count, basin_area, basin_topoind,&
+       & fetch_basin, basin_id, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
+       & inflow_grid, inflow_basin)
+    !
+    !
+    IMPLICIT NONE
+    !
+    ! The aim of this routine is to kill a basin (that is put into another larger one). When
+    ! we do this we need to be careful and change all associated variables.
+    !
+    INTEGER(i_std)                                 :: tokill, totakeover
+    INTEGER(i_std)                                 :: nbpt, ib
+    !
+    INTEGER(i_std)                                 :: nwbas
+    INTEGER(i_std), DIMENSION(nbpt)                :: basin_count
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: basin_id
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: basin_flowdir
+    REAL(r_std), DIMENSION(nbpt,nwbas)             :: basin_area
+    REAL(r_std), DIMENSION(nbpt,nwbas)             :: basin_topoind
+    REAL(r_std), DIMENSION(nbpt,nwbas)             :: fetch_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: outflow_grid
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: outflow_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas)          :: inflow_number
+    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas)    :: inflow_basin
+    INTEGER(i_std), DIMENSION(nbpt,nwbas,nwbas)    :: inflow_grid
+    !
+    !  LOCAL
+    !
+    INTEGER(i_std) :: inf, ibs, ing, inb, ibasf, igrif, it
+    LOGICAL       :: doshift
+    !
+    ! Update the information needed in the basin "totakeover"
+    ! For the moment only area
+!!$    !
+!!$    WRITE(numout,*) 'KILL BASIN :', ib, tokill, totakeover, basin_id(ib,tokill), basin_id(ib,totakeover)
+!!$    !
+    !
+    basin_area(ib, totakeover) = basin_area(ib, totakeover) +  basin_area(ib, tokill)
+    basin_topoind(ib, totakeover) = (basin_topoind(ib, totakeover) + basin_topoind(ib, tokill))/2.0
+    !
+    ! Add the fetch of the basin will kill to the one which gets the water
+    !
+    fetch_basin(ib, totakeover) = fetch_basin(ib, totakeover) + fetch_basin(ib, tokill)
+    igrif = outflow_grid(ib,totakeover)
+    ibasf = outflow_basin(ib,totakeover)
+    !
+    inf = 0
+    DO WHILE (igrif .GT. 0)
+       fetch_basin(igrif,ibasf) =  fetch_basin(igrif,ibasf) + fetch_basin(ib, tokill) 
+       it = outflow_grid(igrif, ibasf)
+       ibasf = outflow_basin(igrif, ibasf)
+       igrif = it
+       inf = inf + 1
+    ENDDO
+    !
+    ! Take out the basin we have just rerouted from the fetch of the basins in which it used to flow.
+    !
+    igrif = outflow_grid(ib,tokill)
+    ibasf = outflow_basin(ib,tokill)
+    !
+    DO WHILE (igrif .GT. 0)
+       fetch_basin(igrif,ibasf) =  fetch_basin(igrif,ibasf) - fetch_basin(ib, tokill)
+       it = outflow_grid(igrif, ibasf)
+       ibasf = outflow_basin(igrif, ibasf)
+       igrif = it
+    ENDDO   
+    !
+    !  Redirect the flows which went into the basin to be killed before we change everything
+    !
+    DO inf = 1, inflow_number(ib, tokill)
+       outflow_basin(inflow_grid(ib, tokill, inf), inflow_basin(ib, tokill, inf)) = totakeover
+       inflow_number(ib, totakeover) = inflow_number(ib, totakeover) + 1
+       inflow_grid(ib, totakeover,  inflow_number(ib, totakeover)) = inflow_grid(ib, tokill, inf)
+       inflow_basin(ib, totakeover,  inflow_number(ib, totakeover)) = inflow_basin(ib, tokill, inf)
+    ENDDO
+    !
+    ! Take out the basin to be killed from the list of inflow basins of the downstream basin
+    ! (In case the basin does not flow into an ocean or lake)
+    !
+    IF ( outflow_grid(ib,tokill) .GT. 0) THEN
+       !
+       ing = outflow_grid(ib, tokill)
+       inb = outflow_basin(ib, tokill)
+       doshift = .FALSE.
+       !
+       DO inf = 1, inflow_number(ing, inb)
+          IF ( doshift ) THEN
+             inflow_grid(ing, inb, inf-1) = inflow_grid(ing, inb, inf)
+             inflow_basin(ing, inb, inf-1) = inflow_basin(ing, inb, inf)
+          ENDIF
+          IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
+             doshift = .TRUE.
+          ENDIF
+       ENDDO
+       !
+       ! This is only to allow for the last check
+       !
+       inf = inflow_number(ing, inb)
+       IF ( inflow_grid(ing, inb, inf) .EQ. ib .AND. inflow_basin(ing, inb, inf) .EQ. tokill) THEN
+          doshift = .TRUE.
+       ENDIF
+       !
+       IF ( .NOT. doshift ) THEN
+          WRITE(numout,*) 'Strange we did not find the basin to kill in the downstream basin'
+          STOP 'routing_killbas'
+       ENDIF
+       inflow_number(ing, inb) = inflow_number(ing, inb) - 1
+       !
+    ENDIF
+    !
+    ! Now remove from the arrays the information of basin "tokill"
+    !
+    basin_id(ib, tokill:basin_count(ib)-1) = basin_id(ib, tokill+1:basin_count(ib))
+    basin_flowdir(ib, tokill:basin_count(ib)-1) = basin_flowdir(ib, tokill+1:basin_count(ib))
+    basin_area(ib, tokill:basin_count(ib)-1) = basin_area(ib, tokill+1:basin_count(ib))
+    basin_area(ib, basin_count(ib):nwbas) = zero
+    basin_topoind(ib, tokill:basin_count(ib)-1) = basin_topoind(ib, tokill+1:basin_count(ib))
+    basin_topoind(ib, basin_count(ib):nwbas) = zero
+    fetch_basin(ib, tokill:basin_count(ib)-1) = fetch_basin(ib, tokill+1:basin_count(ib))
+    fetch_basin(ib, basin_count(ib):nwbas) = zero
+    !
+    ! Before we remove the information from the outflow fields we have to correct the corresponding inflow fields
+    ! of the grids into which the flow goes
+    !
+    DO ibs = tokill+1,basin_count(ib)
+       ing = outflow_grid(ib, ibs)
+       inb = outflow_basin(ib, ibs)
+       IF ( ing .GT. 0 ) THEN
+          DO inf = 1, inflow_number(ing, inb)
+             IF ( inflow_grid(ing,inb,inf) .EQ. ib .AND. inflow_basin(ing,inb,inf) .EQ. ibs) THEN
+                inflow_basin(ing,inb,inf) = ibs - 1
+             ENDIF
+          ENDDO
+       ENDIF
+    ENDDO
+    outflow_grid(ib, tokill:basin_count(ib)-1) = outflow_grid(ib, tokill+1:basin_count(ib))
+    outflow_basin(ib, tokill:basin_count(ib)-1) = outflow_basin(ib, tokill+1:basin_count(ib))
+    !
+    ! Basins which moved down also need to redirect their incoming flows.
+    !
+    DO ibs=tokill+1, basin_count(ib)
+       DO inf = 1, inflow_number(ib, ibs)
+          outflow_basin(inflow_grid(ib, ibs, inf), inflow_basin(ib, ibs, inf)) = ibs-1
+       ENDDO
+    ENDDO
+    !
+    ! Shift the inflow basins
+    !
+    DO it = tokill+1,basin_count(ib)
+       inflow_grid(ib, it-1, 1:inflow_number(ib,it)) =  inflow_grid(ib, it, 1:inflow_number(ib,it))
+       inflow_basin(ib, it-1, 1:inflow_number(ib,it)) =  inflow_basin(ib, it, 1:inflow_number(ib,it))
+       inflow_number(ib,it-1) = inflow_number(ib,it)
+    ENDDO
+    !
+    basin_count(ib) = basin_count(ib) - 1
+    !
+  END SUBROUTINE routing_killbas 
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_names(numlar, basin_names)
+    !
+    IMPLICIT NONE
+    !
+    ! Arguments
+    !
+    INTEGER(i_std), INTENT(in)        :: numlar
+    CHARACTER(LEN=*), INTENT(inout)  :: basin_names(numlar)
+    !
+    ! Local
+    !
+    INTEGER(i_std), PARAMETER               :: listleng=349
+    INTEGER(i_std)                          :: lenstr, i
+    CHARACTER(LEN=60), DIMENSION(listleng) :: list_names
+    CHARACTER(LEN=60)                      :: tmp_str
+    !
+    lenstr = LEN(basin_names(1))
+    !
+    list_names(1) = "Amazon"
+    list_names(2) = "Nile"
+    list_names(3) = "Zaire"
+    list_names(4) = "Mississippi"
+    list_names(5) = "Amur"
+    list_names(6) = "Parana"
+    list_names(7) = "Yenisei"
+    list_names(8) = "Ob"
+    list_names(9) = "Lena"
+    list_names(10) = "Niger"
+    list_names(11) = "Zambezi"
+    list_names(12) = "Yangtze"
+    list_names(13) = "Chang Jiang"
+    list_names(14) = "Mackenzie"
+    list_names(15) = "Ganges"
+    list_names(16) = "Chari"
+    list_names(17) = "Volga"
+    list_names(18) = "St. Lawrence"
+    list_names(19) = "Indus"
+    list_names(20) = "Syr-Darya"
+    list_names(21) = "Nelson"
+    list_names(22) = "Orinoco"
+    list_names(23) = "Murray"
+    list_names(24) = "Great Artesian Basin"
+    list_names(25) = "Shatt el Arab"
+    list_names(26) = "Orange"
+    list_names(27) = "Huang He"
+    list_names(28) = "Yukon"
+    list_names(29) = "Senegal"
+    list_names(30) = "Chott Jerid"
+    list_names(31) = "Jubba"
+    list_names(32) = "Colorado (Ari)"
+    list_names(33) = "Rio Grande (US)"
+    list_names(34) = "Danube"
+    list_names(35) = "Mekong"
+    list_names(36) = "Tocantins"
+    list_names(37) = "Wadi al Farigh"
+    list_names(38) = "Tarim"
+    list_names(39) = "Columbia"
+    list_names(40) = "Noname (GHAASBasin49)"
+    list_names(41) = "Kolyma"
+    list_names(42) = "Sao Francisco"
+    list_names(43) = "Amu-Darya"
+    list_names(44) = "Noname (GHAASBasin51)"
+    list_names(45) = "Dnepr"
+    list_names(46) = "Noname (GHAASBasin61)"
+    list_names(47) = "Don"
+    list_names(48) = "Colorado (Arg)"
+    list_names(49) = "Limpopo"
+    list_names(50) = "GHAASBasin50"
+    list_names(51) = "Zhujiang"
+    list_names(52) = "Irrawaddy"
+    list_names(53) = "Volta"
+    list_names(54) = "GHAASBasin54"
+    list_names(55) = "Farah"
+    list_names(56) = "Khatanga"
+    list_names(57) = "Dvina"
+    list_names(58) = "Urugay"
+    list_names(59) = "Qarqan"
+    list_names(60) = "Noname (GHAASBasin75)"
+    list_names(61) = "Parnaiba"
+    list_names(62) = "Noname (GHAASBasin73)"
+    list_names(63) = "Indigirka"
+    list_names(64) = "Churchill (Hud)"
+    list_names(65) = "Godavari"
+    list_names(66) = "Pur - Taz"
+    list_names(67) = "Pechora"
+    list_names(68) = "Baker"
+    list_names(69) = "Ural"
+    list_names(70) = "Neva"
+    list_names(71) = "Liao"
+    list_names(72) = "Salween"
+    list_names(73) = "GHAASBasin73"
+    list_names(74) = "Jordan"
+    list_names(75) = "Noname (GHAASBasin78)"
+    list_names(76) = "Magdalena"
+    list_names(77) = "Krishna"
+    list_names(78) = "Salado"
+    list_names(79) = "Fraser"
+    list_names(80) = "Hai Ho"
+    list_names(81) = "Huai"
+    list_names(82) = "Yana"
+    list_names(83) = "Noname (GHAASBasin95)"
+    list_names(84) = "Noname (GHAASBasin105)"
+    list_names(85) = "Kura"
+    list_names(86) = "Olenek"
+    list_names(87) = "Ogooue"
+    list_names(88) = "Taymyr"
+    list_names(89) = "Negro Arg"
+    list_names(90) = "Chubut"
+    list_names(91) = "GHAASBasin91"
+    list_names(92) = "Noname (GHAASBasin122)"
+    list_names(93) = "Noname (GHAASBasin120)"
+    list_names(94) = "Sacramento"
+    list_names(95) = "Fitzroy West"
+    list_names(96) = "Grande de Santiago"
+    list_names(97) = "Rufiji"
+    list_names(98) = "Wisla"
+    list_names(99) = "Noname (GHAASBasin47)"
+    list_names(100) = "Noname (GHAASBasin127)"
+    list_names(101) = "Hong"
+    list_names(102) = "Noname (GHAASBasin97)"
+    list_names(103) = "Swan-Avon"
+    list_names(104) = "Rhine"
+    list_names(105) = "Cuanza"
+    list_names(106) = "GHAASBasin106"
+    list_names(107) = "Noname (GHAASBasin142)"
+    list_names(108) = "Roviuna"
+    list_names(109) = "Essequibo"
+    list_names(110) = "Elbe"
+    list_names(111) = "Koksoak"
+    list_names(112) = "Chao Phraya"
+    list_names(113) = "Brahmani"
+    list_names(114) = "Noname (GHAASBasin165)"
+    list_names(115) = "Pyasina"
+    list_names(116) = "Fitzroy East"
+    list_names(117) = "Noname (GHAASBasin173)"
+    list_names(118) = "Albany"
+    list_names(119) = "Sanaga"
+    list_names(120) = "GHAASBasin120"
+    list_names(121) = "Noname (GHAASBasin178)"
+    list_names(122) = "Noname (GHAASBasin148)"
+    list_names(123) = "Brazos (Tex)"
+    list_names(124) = "GHAASBasin124"
+    list_names(125) = "Alabama"
+    list_names(126) = "Noname (GHAASBasin174)"
+    list_names(127) = "Noname (GHAASBasin179)"
+    list_names(128) = "Balsas"
+    list_names(129) = "Noname (GHAASBasin172)"
+    list_names(130) = "Burdekin"
+    list_names(131) = "Colorado (Texas)"
+    list_names(132) = "Noname (GHAASBasin150)"
+    list_names(133) = "Odra"
+    list_names(134) = "Loire"
+    list_names(135) = "Noname (GHAASBasin98)"
+    list_names(136) = "Galana"
+    list_names(137) = "Kuskowin"
+    list_names(138) = "Moose"
+    list_names(139) = "Narmada"
+    list_names(140) = "GHAASBasin140"
+    list_names(141) = "GHAASBasin141"
+    list_names(142) = "Flinders"
+    list_names(143) = "Kizil Irmak"
+    list_names(144) = "GHAASBasin144"
+    list_names(145) = "Save"
+    list_names(146) = "Roper"
+    list_names(147) = "Churchill (Atlantic)"
+    list_names(148) = "GHAASBasin148"
+    list_names(149) = "Victoria"
+    list_names(150) = "Back"
+    list_names(151) = "Bandama"
+    list_names(152) = "Severn (Can)"
+    list_names(153) = "Po"
+    list_names(154) = "GHAASBasin154"
+    list_names(155) = "GHAASBasin155"
+    list_names(156) = "GHAASBasin156"
+    list_names(157) = "Rhone"
+    list_names(158) = "Tana (Ken)"
+    list_names(159) = "La Grande"
+    list_names(160) = "GHAASBasin160"
+    list_names(161) = "Cunene"
+    list_names(162) = "Douro"
+    list_names(163) = "GHAASBasin163"
+    list_names(164) = "Nemanus"
+    list_names(165) = "GHAASBasin165"
+    list_names(166) = "Anabar"
+    list_names(167) = "Hayes"
+    list_names(168) = "Mearim"
+    list_names(169) = "GHAASBasin169"
+    list_names(170) = "Panuco"
+    list_names(171) = "GHAASBasin171"
+    list_names(172) = "Doce"
+    list_names(173) = "Gasgoyne"
+    list_names(174) = "GHAASBasin174"
+    list_names(175) = "GHAASBasin175"
+    list_names(176) = "Ashburton"
+    list_names(177) = "GHAASBasin177"
+    list_names(178) = "Peel"
+    list_names(179) = "Daugava"
+    list_names(180) = "GHAASBasin180"
+    list_names(181) = "Ebro"
+    list_names(182) = "Comoe"
+    list_names(183) = "Jacui"
+    list_names(184) = "GHAASBasin184"
+    list_names(185) = "Kapuas"
+    list_names(186) = "GHAASBasin186"
+    list_names(187) = "Penzhina"
+    list_names(188) = "Cauweri"
+    list_names(189) = "GHAASBasin189"
+    list_names(190) = "Mamberamo"
+    list_names(191) = "Sepik"
+    list_names(192) = "GHAASBasin192"
+    list_names(193) = "Sassandra"
+    list_names(194) = "GHAASBasin194"
+    list_names(195) = "GHAASBasin195"
+    list_names(196) = "Nottaway"
+    list_names(197) = "Barito"
+    list_names(198) = "GHAASBasin198"
+    list_names(199) = "Seine"
+    list_names(200) = "Tejo"
+    list_names(201) = "GHAASBasin201"
+    list_names(202) = "Gambia"
+    list_names(203) = "Susquehanna"
+    list_names(204) = "Dnestr"
+    list_names(205) = "Murchinson"
+    list_names(206) = "Deseado"
+    list_names(207) = "Mitchell"
+    list_names(208) = "Mahakam"
+    list_names(209) = "GHAASBasin209"
+    list_names(210) = "Pangani"
+    list_names(211) = "GHAASBasin211"
+    list_names(212) = "GHAASBasin212"
+    list_names(213) = "GHAASBasin213"
+    list_names(214) = "GHAASBasin214"
+    list_names(215) = "GHAASBasin215"
+    list_names(216) = "Bug"
+    list_names(217) = "GHAASBasin217"
+    list_names(218) = "Usumacinta"
+    list_names(219) = "Jequitinhonha"
+    list_names(220) = "GHAASBasin220"
+    list_names(221) = "Corantijn"
+    list_names(222) = "Fuchun Jiang"
+    list_names(223) = "Copper"
+    list_names(224) = "Tapti"
+    list_names(225) = "Menjiang"
+    list_names(226) = "Karun"
+    list_names(227) = "Mezen"
+    list_names(228) = "Guadiana"
+    list_names(229) = "Maroni"
+    list_names(230) = "GHAASBasin230"
+    list_names(231) = "Uda"
+    list_names(232) = "GHAASBasin232"
+    list_names(233) = "Kuban"
+    list_names(234) = "Colville"
+    list_names(235) = "Thaane"
+    list_names(236) = "Alazeya"
+    list_names(237) = "Paraiba do Sul"
+    list_names(238) = "GHAASBasin238"
+    list_names(239) = "Fortesque"
+    list_names(240) = "GHAASBasin240"
+    list_names(241) = "GHAASBasin241"
+    list_names(242) = "Winisk"
+    list_names(243) = "GHAASBasin243"
+    list_names(244) = "GHAASBasin244"
+    list_names(245) = "Ikopa"
+    list_names(246) = "Gilbert"
+    list_names(247) = "Kouilou"
+    list_names(248) = "Fly"
+    list_names(249) = "GHAASBasin249"
+    list_names(250) = "GHAASBasin250"
+    list_names(251) = "GHAASBasin251"
+    list_names(252) = "Mangoky"
+    list_names(253) = "Damodar"
+    list_names(254) = "Onega"
+    list_names(255) = "Moulouya"
+    list_names(256) = "GHAASBasin256"
+    list_names(257) = "Ord"
+    list_names(258) = "GHAASBasin258"
+    list_names(259) = "GHAASBasin259"
+    list_names(260) = "GHAASBasin260"
+    list_names(261) = "GHAASBasin261"
+    list_names(262) = "Narva"
+    list_names(263) = "GHAASBasin263"
+    list_names(264) = "Seal"
+    list_names(265) = "Cheliff"
+    list_names(266) = "Garonne"
+    list_names(267) = "Rupert"
+    list_names(268) = "GHAASBasin268"
+    list_names(269) = "Brahmani"
+    list_names(270) = "Sakarya"
+    list_names(271) = "Gourits"
+    list_names(272) = "Sittang"
+    list_names(273) = "Rajang"
+    list_names(274) = "Evros"
+    list_names(275) = "Appalachicola"
+    list_names(276) = "Attawapiskat"
+    list_names(277) = "Lurio"
+    list_names(278) = "Daly"
+    list_names(279) = "Penner"
+    list_names(280) = "GHAASBasin280"
+    list_names(281) = "GHAASBasin281"
+    list_names(282) = "Guadalquivir"
+    list_names(283) = "Nadym"
+    list_names(284) = "GHAASBasin284"
+    list_names(285) = "Saint John"
+    list_names(286) = "GHAASBasin286"
+    list_names(287) = "Cross"
+    list_names(288) = "Omoloy"
+    list_names(289) = "Oueme"
+    list_names(290) = "GHAASBasin290"
+    list_names(291) = "Gota"
+    list_names(292) = "Nueces"
+    list_names(293) = "Stikine"
+    list_names(294) = "Yalu"
+    list_names(295) = "Arnaud"
+    list_names(296) = "GHAASBasin296"
+    list_names(297) = "Jequitinhonha"
+    list_names(298) = "Kamchatka"
+    list_names(299) = "GHAASBasin299"
+    list_names(300) = "Grijalva"
+    list_names(301) = "GHAASBasin301"
+    list_names(302) = "Kemijoki"
+    list_names(303) = "Olifants"
+    list_names(304) = "GHAASBasin304"
+    list_names(305) = "Tsiribihina"
+    list_names(306) = "Coppermine"
+    list_names(307) = "GHAASBasin307"
+    list_names(308) = "GHAASBasin308"
+    list_names(309) = "Kovda"
+    list_names(310) = "Trinity"
+    list_names(311) = "Glama"
+    list_names(312) = "GHAASBasin312"
+    list_names(313) = "Luan"
+    list_names(314) = "Leichhardt"
+    list_names(315) = "GHAASBasin315"
+    list_names(316) = "Gurupi"
+    list_names(317) = "GR Baleine"
+    list_names(318) = "Aux Feuilles"
+    list_names(319) = "GHAASBasin319"
+    list_names(320) = "Weser"
+    list_names(321) = "GHAASBasin321"
+    list_names(322) = "GHAASBasin322"
+    list_names(323) = "Yesil"
+    list_names(324) = "Incomati"
+    list_names(325) = "GHAASBasin325"
+    list_names(326) = "GHAASBasin326"
+    list_names(327) = "Pungoe"
+    list_names(328) = "GHAASBasin328"
+    list_names(329) = "Meuse"
+    list_names(330) = "Eastmain"
+    list_names(331) = "Araguari"
+    list_names(332) = "Hudson"
+    list_names(333) = "GHAASBasin333"
+    list_names(334) = "GHAASBasin334"
+    list_names(335) = "GHAASBasin335"
+    list_names(336) = "GHAASBasin336"
+    list_names(337) = "Kobuk"
+    list_names(338) = "Altamaha"
+    list_names(339) = "GHAASBasin339"
+    list_names(340) = "Mand"
+    list_names(341) = "Santee"
+    list_names(342) = "GHAASBasin342"
+    list_names(343) = "GHAASBasin343"
+    list_names(344) = "GHAASBasin344"
+    list_names(345) = "Hari"
+    list_names(346) = "GHAASBasin346"
+    list_names(347) = "Wami"
+    list_names(348) = "GHAASBasin348"
+    list_names(349) = "GHAASBasin349"
+    !
+    basin_names(:) = '    '
+    !
+    DO i=1,numlar
+       tmp_str = list_names(i)
+       basin_names(i) = tmp_str(1:MIN(lenstr,LEN_TRIM(tmp_str)))
+    ENDDO
+    !
+  END SUBROUTINE routing_names
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_irrigmap (nbpt, index, lalo, neighbours, resolution, contfrac, &
+       &                       init_irrig, irrigated, init_flood, floodplains, hist_id, hist2_id)
+    !
+    ! This program will interpoalte the 0.5 x 05 deg based data set to the resolution 
+    ! of the model.
+    !
+    IMPLICIT NONE
+    !
+    ! INPUT
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                ! Number of points for which the data needs to be interpolated
+    INTEGER(i_std), INTENT(in)    :: index(nbpt)         ! Index on the global map.
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)        ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)    :: neighbours(nbpt,8)  ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)  ! The size in m of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)      ! Fraction of land in each grid box
+    LOGICAL, INTENT(in)          :: init_irrig          ! Do we need to compute irrigation ?
+    REAL(r_std), INTENT(out)      :: irrigated(:)        ! Irrigated surface in each grid-box
+    LOGICAL, INTENT(in)          :: init_flood          ! Do we need to compute floodplains
+    REAL(r_std), INTENT(out)      :: floodplains(:)      ! Surface which can be inondated in each grid-box
+    INTEGER(i_std), INTENT(in)    :: hist_id             ! Access to history file
+    INTEGER(i_std), INTENT(in)    :: hist2_id            ! Access to history file 2
+    !
+    ! LOCAL
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, ilf, lastjp, nbexp
+    REAL(r_std) :: lev(1), date, dt, coslat, pi
+    REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
+    INTEGER(i_std) :: itau(1)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, lat_ful, lon_ful
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: irrigated_frac, flood_frac
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: loup_rel, lolow_rel, laup_rel, lalow_rel
+    REAL(r_std) :: area_irrig, area_flood, ax, ay, sgn, surp
+    REAL(r_std) :: lonrel, louprel, lolowrel
+    REAL(r_std)                              :: irrigmap(nbpt)
+    !
+    pi = 4. * ATAN(1.)
+    !
+    !Config Key  = IRRIGATION_FILE
+    !Config Desc = Name of file which contains the map of irrigated areas
+    !Config Def  = irrigated.nc
+    !Config If   = IRRIGATE
+    !Config Help = The name of the file to be opened to read the field
+    !Config        with the area in m^2 of the area irrigated within each
+    !Config        0.5 0.5 deg grid box. The map currently used is the one
+    !Config        developed by the Center for Environmental Systems Research 
+    !Config        in Kassel (1995).
+    !
+    filename = 'irrigated.nc'
+    CALL getin_p('IRRIGATION_FILE',filename)
+    !
+    IF (is_root_prc) CALL flininfo(filename,iml, jml, lml, tml, fid)
+    CALL bcast(iml)
+    CALL bcast(jml)
+    CALL bcast(lml)
+    CALL bcast(tml)
+    !
+    !
+    ALLOCATE (lat_rel(iml,jml))
+    ALLOCATE (lon_rel(iml,jml))
+    ALLOCATE (laup_rel(iml,jml))
+    ALLOCATE (loup_rel(iml,jml))
+    ALLOCATE (lalow_rel(iml,jml))
+    ALLOCATE (lolow_rel(iml,jml))
+    ALLOCATE (lat_ful(iml+2,jml+2))
+    ALLOCATE (lon_ful(iml+2,jml+2))
+    ALLOCATE (irrigated_frac(iml,jml))
+    ALLOCATE (flood_frac(iml,jml))
+    !
+    IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
+    CALL bcast(lon_rel)
+    CALL bcast(lat_rel)
+    CALL bcast(lev)
+    CALL bcast(itau)
+    CALL bcast(date)
+    CALL bcast(dt)
+    
+    !
+    IF (is_root_prc) CALL flinget(fid, 'irrig', iml, jml, lml, tml, 1, 1, irrigated_frac)
+    CALL bcast(irrigated_frac)
+    IF (is_root_prc) CALL flinget(fid, 'inundated', iml, jml, lml, tml, 1, 1, flood_frac)
+    CALL bcast(flood_frac)
+    !
+    IF (is_root_prc) CALL flinclo(fid)
+    !
+    ! Set to zero all fraction which are less than 0.5%
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          !
+          IF ( irrigated_frac(ip,jp) .LT. undef_sechiba-un) THEN
+             irrigated_frac(ip,jp) = irrigated_frac(ip,jp)/100.
+             IF ( irrigated_frac(ip,jp) < 0.005 ) irrigated_frac(ip,jp) = zero
+          ENDIF
+          !
+          IF ( flood_frac(ip,jp) .LT. undef_sechiba-un) THEN
+             flood_frac(ip,jp) = flood_frac(ip,jp)/100
+             IF ( flood_frac(ip,jp) < 0.005 )  flood_frac(ip,jp) = zero
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    WRITE(numout,*) 'lon_rel : ', MAXVAL(lon_rel), MINVAL(lon_rel)
+    WRITE(numout,*) 'lat_rel : ', MAXVAL(lat_rel), MINVAL(lat_rel)
+    WRITE(numout,*) 'irrigated_frac : ', MINVAL(irrigated_frac, MASK=irrigated_frac .GT. 0), &
+         &                          MAXVAL(irrigated_frac, MASK=irrigated_frac .LT. undef_sechiba)
+    WRITE(numout,*) 'flood_frac : ', MINVAL(flood_frac, MASK=flood_frac .GT. 0), &
+         &                      MAXVAL(flood_frac, MASK=flood_frac .LT. undef_sechiba)
+    !
+    nbexp = 0
+    !
+    !    Duplicate the border assuming we have a global grid going from west to east
+    !
+    lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
+    lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
+    !
+    IF ( lon_rel(iml,1) .LT. lon_ful(2,2)) THEN
+       lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
+       lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+    ELSE
+       lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
+       lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+    ENDIF
+    
+    IF ( lon_rel(1,1) .GT. lon_ful(iml+1,2)) THEN
+       lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
+       lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+    ELSE
+       lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
+       lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+    ENDIF
+    !
+    sgn = lat_rel(1,1)/ABS(lat_rel(1,1))
+    lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
+    sgn = lat_rel(1,jml)/ABS(lat_rel(1,jml))
+    lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
+    lat_ful(1,1) = lat_ful(iml+1,1)
+    lat_ful(iml+2,1) = lat_ful(2,1)
+    lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
+    lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
+    !
+    ! Add the longitude lines to the top and bottom
+    !
+    lon_ful(:,1) = lon_ful(:,2) 
+    lon_ful(:,jml+2) = lon_ful(:,jml+1) 
+    !
+    !  Get the upper and lower limits of each grid box
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          loup_rel(ip,jp) =MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+          lolow_rel(ip,jp) =MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), 0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+          laup_rel(ip,jp) =MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+          lalow_rel(ip,jp) =MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), 0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+       ENDDO
+    ENDDO
+    !
+    !   Now we take each grid point and find out which values from the forcing we need to average
+    !
+    DO ib =1, nbpt
+       !
+       !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+       !  into longitudes and latitudes we do not have the problem of periodicity.
+       ! coslat is a help variable here !
+       !
+       coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
+       !
+       lon_up = lalo(ib,2)+ resolution(ib,1)/(2.0*coslat) 
+       lon_low =lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+       !
+       coslat = pi/180. * R_Earth
+       !
+       lat_up =lalo(ib,1)+resolution(ib,2)/(2.0*coslat) 
+       lat_low =lalo(ib,1)-resolution(ib,2)/(2.0*coslat) 
+       !
+       !
+       !  Find the grid boxes from the data that go into the model's boxes
+       !  We still work as if we had a regular grid ! Well it needs to be localy regular so
+       !  so that the longitude at the latitude of the last found point is close to the one of the next point.
+       !
+       lastjp = 1
+       area_irrig = zero
+       area_flood = zero
+       DO ip=1,iml
+          !
+          !  Either the center of the data grid point is in the interval of the model grid or
+          !  the East and West limits of the data grid point are on either sides of the border of
+          !  the data grid.
+          !
+          !
+          !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+          !  into longitudes and latitudes we do not have the problem of periodicity.
+          ! coslat is a help variable here !
+          !
+          !
+          !  To do that correctly we have to check if the grid box sits on the date-line.
+          !
+          IF ( lon_low < -180.0 ) THEN
+             lonrel = MOD( lon_rel(ip,lastjp) - 360.0, 360.0)
+             lolowrel = MOD( lolow_rel(ip,lastjp) - 360.0, 360.0)
+             louprel = MOD( loup_rel(ip,lastjp) - 360.0, 360.0)
+             !
+          ELSE IF ( lon_up > 180.0 ) THEN
+             lonrel = MOD( 360. - lon_rel(ip,lastjp), 360.0)
+             lolowrel = MOD( 360. - lolow_rel(ip,lastjp), 360.0)
+             louprel = MOD( 360. - loup_rel(ip,lastjp), 360.0)
+          ELSE
+             lonrel = lon_rel(ip,lastjp)
+             lolowrel = lolow_rel(ip,lastjp)
+             louprel = loup_rel(ip,lastjp)
+          ENDIF
+          !
+          !
+          !
+          IF ( lonrel > lon_low .AND. lonrel < lon_up .OR. &
+            & lolowrel < lon_low .AND.  louprel > lon_low .OR. &
+            & lolowrel < lon_up  .AND.  louprel > lon_up ) THEN
+             !  
+             DO jp = 1, jml
+                !
+                ! Now that we have the longitude let us find the latitude
+                !
+                IF ( lat_rel(ip,jp) > lat_low .AND. lat_rel(ip,jp) < lat_up .OR. &
+                     & lalow_rel(ip,jp) < lat_low .AND. laup_rel(ip,jp) > lat_low .OR.&
+                     & lalow_rel(ip,jp) < lat_up .AND. laup_rel(ip,jp) > lat_up) THEN
+                   !
+                   lastjp = jp
+                   !
+                   ! Mising values in the file are assumed to be 1e20
+                   ! 
+                   IF ( lon_low < -180.0 ) THEN
+                      lolowrel = MOD( lolow_rel(ip,jp) - 360.0, 360.0)
+                      louprel = MOD( loup_rel(ip,jp) - 360.0, 360.0)
+                      !
+                   ELSE IF ( lon_up > 180.0 ) THEN
+                      lolowrel = MOD( 360. - lolow_rel(ip,jp), 360.0)
+                      louprel = MOD( 360. - loup_rel(ip,jp), 360.0)
+                   ELSE
+                      lolowrel = lolow_rel(ip,jp)
+                      louprel = loup_rel(ip,jp)
+                   ENDIF
+                   !
+                   ! Get the area of the fine grid in the model grid
+                   !
+                   coslat = MAX( COS( lat_rel(ip,jp) * pi/180. ), 0.001 )
+                   ax = (MIN(lon_up,louprel)-MAX(lon_low, lolowrel))*pi/180. * R_Earth * coslat
+                   ay = (MIN(lat_up, laup_rel(ip,jp))-MAX(lat_low,lalow_rel(ip,jp)))*pi/180. * R_Earth
+                   !
+                   IF (irrigated_frac(ip,jp) .LT. undef_sechiba-1.) THEN
+                      area_irrig = area_irrig + ax*ay*irrigated_frac(ip,jp)
+                   ENDIF
+                   !
+                   IF (flood_frac(ip,jp) .LT. undef_sechiba-un) THEN
+                      area_flood = area_flood + ax*ay*flood_frac(ip,jp)
+                   ENDIF                      
+                   !
+                ENDIF
+                !
+             ENDDO
+             !
+          ENDIF
+          !
+       ENDDO
+       !
+       ! Put the toal irrigated and flooded areas in the output variables
+       !
+       IF ( init_irrig ) THEN
+          irrigated(ib) = MIN(area_irrig, resolution(ib,1)*resolution(ib,2)*contfrac(ib))
+          IF ( irrigated(ib) < 0 ) THEN
+             WRITE(numout,*) 'We have a problem here : ', irrigated(ib) 
+             WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
+             WRITE(numout,*) area_irrig
+             STOP
+          ENDIF
+          ! Compute a diagnostic of the map.
+          IF(contfrac(ib).GT.zero) THEN
+             irrigmap (ib) = irrigated(ib) / ( resolution(ib,1)*resolution(ib,2)*contfrac(ib) )
+          ELSE
+             irrigmap (ib) = zero
+          ENDIF
+          !
+       ENDIF
+       !
+       IF ( init_flood ) THEN
+          floodplains(ib) = MIN(area_flood, resolution(ib,1)*resolution(ib,2)*contfrac(ib))
+          IF ( floodplains(ib) < 0 ) THEN
+             WRITE(numout,*) 'We have a problem here : ', floodplains(ib) 
+             WRITE(numout,*) 'resolution :', resolution(ib,1), resolution(ib,2)
+             WRITE(numout,*) area_flood
+             STOP
+          ENDIF
+       ENDIF
+       !
+       !
+    ENDDO
+    !
+    IF ( init_irrig .AND. init_flood ) THEN
+       DO ib = 1, nbpt
+          IF ( floodplains(ib)+irrigated(ib) > resolution(ib,1)*resolution(ib,2)*contfrac(ib) ) THEN
+             surp = (resolution(ib,1)*resolution(ib,2)*contfrac(ib))/(floodplains(ib)+irrigated(ib))
+             floodplains(ib) = floodplains(ib) * surp
+             irrigated(ib) = irrigated(ib) * surp
+          ENDIF
+       ENDDO
+    ENDIF
+    !
+    IF ( init_irrig ) THEN
+       WRITE(numout,*) 'RESULT irrigated : ', MINVAL(irrigated), MAXVAL(irrigated) 
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite(hist_id, 'irrigmap', 1, irrigmap, nbpt, index)
+       ELSE
+          CALL histwrite(hist_id, 'IrrigationMap', 1, irrigated, nbpt, index)
+       ENDIF
+       IF ( hist2_id > 0 ) THEN
+          IF ( .NOT. almaoutput ) THEN
+             CALL histwrite(hist2_id, 'irrigmap', 1, irrigmap, nbpt, index)
+          ELSE
+             CALL histwrite(hist2_id, 'IrrigationMap', 1, irrigated, nbpt, index)
+          ENDIF
+       ENDIF
+    ENDIF
+    !
+    IF ( init_flood ) THEN
+       WRITE(numout,*) 'RESULT floodplains : ', MINVAL(floodplains), MAXVAL(floodplains) 
+    ENDIF
+    !
+  END SUBROUTINE routing_irrigmap
+  !
+  !---------------------------------------------------------------------------------
+  !
+  SUBROUTINE routing_waterbal(nbpt, firstcall, runoff, drainage, returnflow, &
+               & irrigation, riverflow, coastalflow)
+    !
+    IMPLICIT NONE
+    !
+    ! This subroutine should allow us to check the water balance in the routing module.
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                ! Domain size
+    LOGICAL, INTENT(in)          :: firstcall           ! controls behaviour
+    REAL(r_std), INTENT(in)       :: runoff(nbpt)        ! grid-point runoff
+    REAL(r_std), INTENT(in)       :: drainage(nbpt)      ! grid-point drainage
+    REAL(r_std), INTENT(in)       :: returnflow(nbpt)    ! The water flow which returns to the grid box (kg/m^2/dt)
+    REAL(r_std), INTENT(in)       :: irrigation(nbpt)    ! Irrigation flux (kg/m^2 per dt)
+    REAL(r_std), INTENT(in)       :: riverflow(nbpt)     ! Outflow of the major rivers (kg/dt)
+    REAL(r_std), INTENT(in)       :: coastalflow(nbpt)   ! Outflow on coastal points by small basins (kg/dt)
+    !
+    ! We sum-up all the water we have in the warious reservoirs
+    !
+    REAL(r_std), SAVE :: totw_stream, totw_fast, totw_slow, totw_lake
+    REAL(r_std), SAVE :: totw_in, totw_out, totw_return, totw_irrig, totw_river, totw_coastal
+    REAL(r_std)       :: totarea, area
+    !
+    ! Just to make sure we do not get too large numbers !
+    !
+    REAL(r_std), PARAMETER :: scaling = 1.0E+6
+    REAL(r_std), PARAMETER :: allowed_err = 50.
+    !
+    INTEGER(i_std)    :: ig
+    !
+    IF ( firstcall ) THEN
+       !
+       totw_stream = zero
+       totw_fast = zero
+       totw_slow = zero
+       totw_lake = zero
+       totw_in = zero
+       !
+       DO ig=1,nbpt
+          !
+          totarea = SUM(routing_area(ig,:))
+          !
+          totw_stream = totw_stream + SUM(stream_reservoir(ig,:)/scaling)
+          totw_fast = totw_fast + SUM(fast_reservoir(ig,:)/scaling)
+          totw_slow = totw_slow + SUM(slow_reservoir(ig,:)/scaling)
+          totw_lake = totw_lake + lake_reservoir(ig)/scaling
+          !
+          totw_in = totw_in + (runoff(ig)*totarea + drainage(ig)*totarea)/scaling
+          !
+       ENDDO
+       !
+    ELSE
+       !
+       totw_out = zero
+       totw_return = zero
+       totw_irrig = zero
+       totw_river = zero
+       totw_coastal = zero
+       area = zero
+       !
+       DO ig=1,nbpt
+          !
+          totarea = SUM(routing_area(ig,:))
+          !
+          totw_stream = totw_stream - SUM(stream_reservoir(ig,:)/scaling)
+          totw_fast = totw_fast - SUM(fast_reservoir(ig,:)/scaling)
+          totw_slow = totw_slow - SUM(slow_reservoir(ig,:)/scaling)
+          totw_lake = totw_lake - lake_reservoir(ig)/scaling
+          !
+          totw_return = totw_return + returnflow(ig)*totarea/scaling
+          totw_irrig = totw_irrig + irrigation(ig)*totarea/scaling
+          totw_river = totw_river + riverflow(ig)/scaling
+          totw_coastal = totw_coastal + coastalflow(ig)/scaling
+          !
+          area = area + totarea
+          !
+       ENDDO
+       totw_out = totw_return + totw_irrig + totw_river + totw_coastal
+       !
+       ! Now we have all the information to balance our water
+       !
+       IF ( ABS((totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in)) > allowed_err ) THEN
+          WRITE(numout,*) 'WARNING : Water not conserved in routing. Limit at ', allowed_err, ' 10^6 kg'
+          WRITE(numout,*) '--Water-- change : stream fast ', totw_stream, totw_fast
+          WRITE(numout,*) '--Water-- change : slow, lake ', totw_slow, totw_lake
+          WRITE(numout,*) '--Water>>> change in the routing res. : ', totw_stream + totw_fast + totw_slow + totw_lake
+          WRITE(numout,*) '--Water input : ', totw_in
+          WRITE(numout,*) '--Water output : ', totw_out
+          WRITE(numout,*) '--Water output : return, irrig ', totw_return, totw_irrig
+          WRITE(numout,*) '--Water output : river, coastal ',totw_river, totw_coastal
+          WRITE(numout,*) '--Water>>> change by fluxes : ', totw_out - totw_in, ' Diff [mm/dt]: ',   &
+               & ((totw_stream + totw_fast + totw_slow + totw_lake) - (totw_out - totw_in))/area
+       ENDIF
+       !
+    ENDIF
+    !
+  END SUBROUTINE routing_waterbal
+  !
+  !
+END MODULE routing
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba.f90	(revision 55)
@@ -0,0 +1,1499 @@
+!! This module computes continental processes SECHIBA
+!!
+!! See also this graph <a href="http:shema.gif"><img SRC="  http:shema.gif" WIDTH="25" LENGTH="25"></A>
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!! 
+MODULE sechiba
+
+  ! routines called : diffuco_main, enerbil_main, hydrolc_main, enrbil_fusion, condveg_main, thermosoil_main
+  !
+  USE ioipsl
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_veg
+  USE constantes_co2
+  USE diffuco
+  USE condveg
+  USE enerbil
+  USE hydrol
+  USE hydrolc
+  USE thermosoil
+  USE sechiba_io
+  USE slowproc
+  USE routing
+!  USE write_field_p, only : WriteFieldI_p
+
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! sechiba_main
+  ! sechiba_clear
+  PRIVATE
+  PUBLIC sechiba_main,sechiba_clear
+
+  ! Index arrays we need internaly
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexveg       !! indexing array for the 3D fields of vegetation
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexnobio     !! indexing array for the 3D fields of other surfaces (ice, lakes, ...)
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexsoil      !! indexing array for the 3D fields of soil types
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexgrnd      !! indexing array for the 3D ground heat profiles
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexlayer     !! indexing array for the 3D fields of soil layers 
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION (:) :: indexalb       !! indexing array for the 2 fields of albedo 
+
+  ! three dimensions array allocated, computed, saved and got in sechiba module
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:):: assim_param    !! min+max+opt temps, vcmax, vjmax for photosynthesis
+
+  ! two dimensions array allocated, computed, saved and got in sechiba module
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: veget          !! Fraction of vegetation type        
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: veget_max      !! Max. fraction of vegetation type (LAI -> infty)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: height         !! Vegetation Height (m)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lai            !! Surface foliere
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: gpp            !! STOMATE: GPP. gC/m**2 of total area
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: humrel         !! Relative humidity
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vegstress      !! Vegetation moisture stress (only for vegetation growth)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: soiltype       !! Map of soil types, created in slowproc in the 
+  !! order : silt, sand and clay.
+
+  !
+  ! one dimension array allocated, computed and used in sechiba module and passed to other
+  ! modules called
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vbeta1         !! Snow resistance 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vbeta4         !! Bare soil resistance
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: soilcap        !! Soil calorific capacity
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: soilflx        !! Soil flux
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: temp_sol       !! Soil temperature
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: qsurf          !! near soil air moisture
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: snow           !! Snow mass [Kg/m^2]
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: snow_age       !! Snow age
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: drysoil_frac   !! Fraction of visibly (albedo) Dry soil (Between 0 and 1)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: rsol           !! resistance to bare soil evaporation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: evap_bare_lim  !! Bare soil stress
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: evapot         !! Soil Potential Evaporation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: evapot_corr    !! Soil Potential Evaporation Correction (Milly 1992)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vevapsno       !! Snow evaporation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vevapnu        !! Bare soil evaporation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: t2mdiag        !! 2 meter temperature
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: tot_melt       !! Total melt
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: vbeta          !! Resistance coefficient
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: valpha         !! Resistance coefficient
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: fusion         !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: rau            !! Density
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: deadleaf_cover !! Fraction of soil covered by dead leaves
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: co2_flux       !! CO2 flux (gC/m**2 of average ground/s)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: totfrac_nobio  !! Total fraction of continental ice+lakes+cities+...
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: runoff         !! Surface runoff generated by hydrol
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: drainage       !! Deep drainage generated by hydrol
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: returnflow     !! Routed water which returns into the soil
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: irrigation     !! irrigation going back into the soils
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: emis           !! Surface emissivity
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: z0             !! Surface roughness
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: roughheight    !! Effective height for roughness
+  !
+  ! Arrays which are diagnostics from the physical processes for
+  ! for the biological processes. They are not saved in the restart file because at the first time step,
+  ! they are recalculated. However, they must be saved in memory as they are in slowproc which is called 
+  ! before the modules which calculate them.
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: shumdiag     !! Relative soil moisture
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: litterhumdiag!! litter humidity
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: stempdiag    !! Temperature which controls canopy evolution
+
+  ! two dimensions array allocated, computed and used in sechiba module and passed to other
+  ! modules called
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: qsintveg       !! Water on vegetation due to interception
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vbeta2         !! Interception resistance
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vbeta3         !! Vegetation resistance
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vbetaco2       !! STOMATE: Vegetation resistance to CO2
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: cimean         !! STOMATE: Mean ci
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: vevapwet       !! Interception
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: transpir       !! Transpiration
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: qsintmax       !! Maximum water on vegetation for interception
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: rveget         !! Vegetation resistance
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: snow_nobio     !! Water balance over other surface types (that is snow !)
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: snow_nobio_age !! Snow age on other surface types
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: frac_nobio     !! Fraction of continental ice, lakes, ...
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: albedo         !! Surface albedo for visible and NIR
+  !
+  ! variables used inside sechiba module : declaration and initialisation
+  !
+  LOGICAL, SAVE                                   :: l_first_sechiba = .TRUE.!! Initialisation has to be done one time
+  CHARACTER(LEN=80) , SAVE                             :: var_name                !! To store variables names for I/O
+
+  LOGICAL, SAVE                                   :: river_routing           !! Flag that decides if we route.
+  LOGICAL, SAVE                                   :: hydrol_cwrr             !! Selects the CWRR hydrology.
+
+  LOGICAL, SAVE                                   :: myfalse=.FALSE. 
+  LOGICAL, SAVE                                   :: mytrue=.TRUE.
+
+CONTAINS
+
+  !! Main routine for *sechiba* module.
+  !!
+  !! Should be called two times:
+  !! - first time to have initial values
+  !! - second time to have complete algorithm
+  !! 
+  !! Algorithm:
+  !! 3 series of called SECHIBA processes
+  !! - initialisation (first time only)
+  !! - time step evolution (every time step)
+  !! - prepares output and storage of restart arrays (last time only)
+  !!
+  !! One serie consists of:
+  !! - call sechiba_var_init to do some initialisation
+  !! - call slowproc_main to do some daily initialisation
+  !! - call diffuco_main for diffusion coefficient calculation
+  !! - call enerbil_main for energy bilan calculation
+  !! - call hydrolc_main for hydrologic processes calculation
+  !! - call enerbil_fusion : last part with fusion
+  !! - call condveg_main for surface conditions such as roughness, albedo, and emmisivity
+  !! - call thermosoil_main for soil thermodynamic calculation
+  !! - call sechiba_end to swap new fields to previous
+  !!
+  !! @call sechiba_var_init
+  !! @call slowproc_main
+  !! @call diffuco_main
+  !! @call enerbil_main
+  !! @call hydrolc_main
+  !! @call enerbil_fusion
+  !! @call condveg_main
+  !! @call thermosoil_main
+  !! @call sechiba_end
+  !!
+  SUBROUTINE sechiba_main (kjit, kjpij, kjpindex, index, dtradia, date0, &
+       & ldrestart_read, ldrestart_write, control_in, &
+       & lalo, contfrac, neighbours, resolution,&
+       ! First level conditions
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+!     & zlev, u, v, qair, temp_air, epot_air, ccanopy, &
+    & zlev, u, v, qair, q2m, t2m, temp_air, epot_air, ccanopy, &
+         ! Variables for the implicit coupling
+    & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         ! Rain, snow, radiation and surface pressure
+    & precip_rain, precip_snow, lwdown, swnet, swdown, pb, &
+         ! Output : Fluxes
+    & vevapp, fluxsens, fluxlat, coastalflow, riverflow, &
+         ! Surface temperatures and surface properties
+    & tsol_rad, temp_sol_new, qsurf_out, albedo_out, emis_out, z0_out, &
+         ! File ids
+    & rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC)
+
+    ! interface description for dummy arguments
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjit             !! Time step number 
+    INTEGER(i_std), INTENT(in)                               :: kjpij            !! Total size of size. This is the un-compressed grid
+    INTEGER(i_std), INTENT(in)                               :: kjpindex         !! Domain size
+    INTEGER(i_std),INTENT (in)                               :: rest_id          !! _Restart_ file identifier
+    INTEGER(i_std),INTENT (in)                               :: hist_id          !! _History_ file identifier
+    INTEGER(i_std),INTENT (in)                               :: hist2_id         !! _History_ file 2 identifier
+    INTEGER(i_std),INTENT (in)                               :: rest_id_stom     !! STOMATE's _Restart_ file identifier
+    INTEGER(i_std),INTENT (in)                               :: hist_id_stom     !! STOMATE's _History_ file identifier
+    INTEGER(i_std),INTENT(in)                                :: hist_id_stom_IPCC !! STOMATE's IPCC _history_ file file identifier
+    REAL(r_std), INTENT (in)                                 :: dtradia          !! Time step in seconds
+    REAL(r_std), INTENT (in)                                 :: date0            !! initial date
+    LOGICAL, INTENT(in)                                     :: ldrestart_read   !! Logical for _restart_ file to read
+    LOGICAL, INTENT(in)                                     :: ldrestart_write  !! Logical for _restart_ file to write
+    TYPE(control_type), INTENT(in)                          :: control_in       !! Flags that (de)activate parts of the model
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)          :: lalo             !! Geographical coordinates
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: contfrac         !! Fraction of continent in the grid
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)         :: index            !! Indeces of the points on the map
+    !
+    INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in)       :: neighbours       !! neighoring grid points if land
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)          :: resolution       !! size in x an y of the grid (m)
+    !
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: u                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: v                !! Lowest level wind speed 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: zlev             !! Height of first layer
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: qair             !! Lowest level specific humidity
+! Ajout Nathalie - Juin 2006 - Q2M/t2m pour calcul Rveget
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: q2m              !! 2m specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: t2m              !! 2m air temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: precip_rain      !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: precip_snow      !! Snow precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: lwdown           !! Down-welling long-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swnet            !! Net surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: swdown           !! Down-welling surface short-wave flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_air         !! Air temperature in Kelvin
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: epot_air         !! Air potential energy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: ccanopy          !! CO2 concentration in the canopy
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petAcoef         !! Coeficients A from the PBL resolution
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqAcoef         !! One for T and another for q
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: petBcoef         !! Coeficients B from the PBL resolution
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: peqBcoef         !! One for T and another for q
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)         :: tq_cdrag         !! This is the cdrag without the wind multiplied
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: pb               !! Lowest level pressure
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: coastalflow      !! Diffuse water flow to the oceans
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: riverflow        !! River outflow to the oceans
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: tsol_rad         !! Radiative surface temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: vevapp           !! Total of evaporation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)           :: temp_sol_new     !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: qsurf_out        !! Surface specific humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: z0_out           !! Surface roughness (output diagnostic)
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (out)         :: albedo_out       !! Albedo (output diagnostic)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxsens         !! Sensible chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: fluxlat          !! Latent chaleur flux
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)           :: emis_out         !! Emissivity
+
+    REAL(r_std), ALLOCATABLE, DIMENSION (:)                  :: runoff1,drainage1, soilcap1,soilflx1
+    REAL(r_std), ALLOCATABLE, DIMENSION (:,:)                :: shumdiag1
+
+    REAL(r_std), DIMENSION(kjpindex)                   :: histvar          !! computations for history files
+
+    IF (long_print) WRITE(numout,*) ' kjpindex =',kjpindex
+
+    ! do SECHIBA'S first call initialisation
+
+    IF (l_first_sechiba) THEN
+
+       CALL sechiba_init (kjit, ldrestart_read, kjpij, kjpindex, index, rest_id, control_in, lalo)
+
+       ALLOCATE(runoff1 (kjpindex),drainage1 (kjpindex), soilcap1 (kjpindex),soilflx1 (kjpindex))
+       ALLOCATE(shumdiag1(kjpindex,nbdl))
+       ! 
+       ! computes initialisation of energy bilan
+       !
+       IF (ldrestart_read) THEN
+          
+          IF (long_print) WRITE (numout,*) ' we have to read a restart file for SECHIBA variables'
+          var_name='soilcap' ;
+          CALL ioconf_setatt('UNITS', '-')
+          CALL ioconf_setatt('LONG_NAME','Soil calorific capacity')
+          soilcap1=val_exp
+          IF ( ok_var(var_name) ) THEN
+             CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., soilcap1, "gather", nbp_glo, index_g)
+             IF (MINVAL(soilcap1) < MAXVAL(soilcap1) .OR. MAXVAL(soilcap1) < val_exp) THEN
+                soilcap(:) = soilcap1(:)
+             ENDIF
+          ENDIF
+          !
+          var_name='soilflx' ;
+          CALL ioconf_setatt('UNITS', '-')
+          CALL ioconf_setatt('LONG_NAME','Soil flux')
+          soilflx1=val_exp
+          IF ( ok_var(var_name) ) THEN
+             CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., soilflx1, "gather", nbp_glo, index_g)
+             IF (MINVAL(soilflx1) < MAXVAL(soilflx1)  .OR. MAXVAL(soilflx1) < val_exp) THEN
+                soilflx(:) = soilflx1(:)
+             ENDIF
+          ENDIF
+          !
+          var_name='shumdiag' ;
+          CALL ioconf_setatt('UNITS', '-')
+          CALL ioconf_setatt('LONG_NAME','Relative soil moisture')
+          shumdiag1=val_exp
+          IF ( ok_var(var_name) ) THEN
+             CALL restget_p (rest_id, var_name, nbp_glo, nbdl, 1, kjit, .TRUE., shumdiag1, "gather", nbp_glo, index_g)
+             IF (MINVAL(shumdiag1) < MAXVAL(shumdiag1) .OR. MAXVAL(shumdiag1) < val_exp) THEN
+                shumdiag(:,:) = shumdiag1(:,:)
+             ENDIF
+          ENDIF
+       ENDIF
+
+       !
+       ! computes slow variables
+       !
+       CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+            ldrestart_read, ldrestart_write, control%ok_co2, control%ok_stomate, &
+            index, indexveg, lalo, neighbours, resolution, contfrac, soiltype, &
+            t2mdiag, t2mdiag, temp_sol, stempdiag, &
+            vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
+            deadleaf_cover, &
+            assim_param, &
+            lai, height, veget, frac_nobio, veget_max, totfrac_nobio, qsintmax, &
+            rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+            co2_flux)
+       ! 
+       ! computes initialisation of diffusion coeff
+       !
+
+       CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+!           & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb ,  &
+            & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb ,  &
+            & rsol, evap_bare_lim, evapot, snow, frac_nobio, snow_nobio, totfrac_nobio, &
+            & swnet, swdown, ccanopy, humrel, veget, veget_max, lai, qsintveg, qsintmax, assim_param, &
+            & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
+       ! 
+       ! computes initialisation of energy bilan
+       !
+       CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+            & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
+            & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, &
+            & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+            & vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, t2mdiag, temp_sol, tsol_rad, &
+            & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id) 
+       !
+       ! computes initialisation of hydrologie
+       !
+       IF (ldrestart_read) THEN
+          
+          var_name='runoff' ;
+          CALL ioconf_setatt('UNITS', 'mm/d')
+          CALL ioconf_setatt('LONG_NAME','Complete runoff')
+          runoff1=val_exp
+          IF ( ok_var(var_name) ) THEN
+             CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., runoff1, "gather", nbp_glo, index_g)
+             IF (MINVAL(runoff1) < MAXVAL(runoff1) .OR. MAXVAL(runoff1) < val_exp) THEN
+                runoff(:) = runoff1(:)
+             ENDIF
+          ENDIF
+
+          var_name='drainage' ;
+          CALL ioconf_setatt('UNITS', 'mm/d')
+          CALL ioconf_setatt('LONG_NAME','Deep drainage')
+          drainage1=val_exp
+          IF ( ok_var(var_name) ) THEN
+             CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., drainage1, "gather", nbp_glo, index_g)
+             IF (MINVAL(drainage1) < MAXVAL(drainage1) .OR. MAXVAL(drainage1) < val_exp) THEN
+                drainage(:) = drainage1(:)
+             ENDIF
+          ENDIF
+
+          IF ( ok_var("shumdiag") ) THEN
+             IF (MINVAL(shumdiag1) < MAXVAL(shumdiag1) .OR. MAXVAL(shumdiag1) < val_exp) THEN
+                shumdiag(:,:) = shumdiag1(:,:)
+             ENDIF
+          ENDIF
+       ENDIF
+       !
+       IF ( .NOT. hydrol_cwrr ) THEN
+          CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
+               & temp_sol_new, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+               & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age,&
+               & tot_melt, transpir, precip_rain, precip_snow, returnflow, irrigation, humrel, &
+               & vegstress, rsol, drysoil_frac, evapot, evapot_corr, shumdiag, litterhumdiag, soilcap, rest_id, hist_id, hist2_id) 
+          evap_bare_lim(:) = -un
+       ELSE
+          CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexsoil, indexlayer, &
+               & temp_sol_new, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+               & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age,&
+               & tot_melt, transpir, precip_rain, precip_snow, returnflow, irrigation, humrel, &
+               & vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, &
+               & shumdiag, litterhumdiag, soilcap, soiltype, rest_id, hist_id, hist2_id)
+       ENDIF
+       IF (ldrestart_read) THEN
+          
+          IF ( ok_var("runoff") ) THEN
+             IF (MINVAL(runoff1) < MAXVAL(runoff1) .OR. MAXVAL(runoff1) < val_exp) THEN
+                runoff(:) = runoff1(:)
+             ENDIF
+          ENDIF
+
+          IF ( ok_var("drainage") ) THEN
+             IF (MINVAL(drainage1) < MAXVAL(drainage1) .OR. MAXVAL(drainage1) < val_exp) THEN
+                drainage(:) = drainage1(:)
+             ENDIF
+          ENDIF
+          
+          IF ( ok_var("shumdiag") ) THEN
+             IF (MINVAL(shumdiag1) < MAXVAL(shumdiag1) .OR. MAXVAL(shumdiag1) < val_exp) THEN
+                shumdiag(:,:) = shumdiag1(:,:)
+             ENDIF
+          ENDIF
+       ENDIF
+
+       ! 
+       ! computes initialisation of condveg
+       !
+       CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
+            & lalo, neighbours, resolution, contfrac, veget, veget_max, frac_nobio, totfrac_nobio, &
+            & zlev, snow, snow_age, snow_nobio, snow_nobio_age, &
+            & drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, soiltype, rest_id, hist_id, hist2_id)
+       ! 
+       ! computes initialisation of Soil Thermodynamic
+       !
+       CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+            & index, indexgrnd, temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id) 
+
+       IF (ldrestart_read) THEN
+          IF ( ok_var("soilcap") ) THEN
+             IF (MINVAL(soilcap1) < MAXVAL(soilcap1) .OR. MAXVAL(soilcap1) < val_exp) THEN
+                soilcap(:) = soilcap1(:)
+             ENDIF
+          ENDIF
+          !
+          IF ( ok_var("soilflx") ) THEN
+             IF (MINVAL(soilflx1) < MAXVAL(soilflx1)  .OR. MAXVAL(soilflx1) < val_exp) THEN
+                soilflx(:) = soilflx1(:)
+             ENDIF
+          ENDIF
+       ENDIF
+
+       !
+       ! If we chose to route the water then we call the module. Else variables
+       ! are set to zero.
+       ! 
+       !
+       IF ( river_routing .AND. nbp_glo .GT. 1) THEN
+          CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
+               & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, runoff, &
+               & drainage, evapot_corr, precip_rain, humrel, &
+               & stempdiag, returnflow, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
+       ELSE
+          riverflow(:) = zero
+          coastalflow(:) = zero
+          returnflow(:) = zero
+          irrigation(:) = zero
+       ENDIF
+       !
+       ! Write the internal variables into the output fields
+       !
+       z0_out(:) = z0(:)
+       emis_out(:) = emis(:)
+       albedo_out(:,:) = albedo(:,:) 
+       qsurf_out(:) = qsurf(:)
+
+       DEALLOCATE(runoff1,drainage1,soilcap1,soilflx1)
+       DEALLOCATE(shumdiag1)
+
+       !
+       ! This line should remain last as it ends the initialisation and returns to the caling
+       ! routine.
+       !
+       RETURN
+       !
+    ENDIF
+
+    !
+    ! computes some initialisation every SECHIBA's call
+    !
+    CALL sechiba_var_init (kjpindex, rau, pb, temp_air) 
+
+    ! 
+    ! computes diffusion coeff
+    !
+    CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, u, v, &
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+!        & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb ,  &
+         & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb ,  &
+         & rsol, evap_bare_lim, evapot, snow, frac_nobio, snow_nobio, totfrac_nobio, &
+         & swnet, swdown, ccanopy, humrel, veget, veget_max, lai, qsintveg, qsintmax, assim_param, &
+         & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
+
+    ! 
+    ! computes energy bilan
+    !
+
+    CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, &
+         & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef, &
+         & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, &
+         & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+         & vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, t2mdiag, temp_sol, tsol_rad, &
+         & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id)
+    !
+    ! computes hydrologie
+    !
+    IF ( .NOT. hydrol_cwrr ) THEN
+       CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, &
+            & temp_sol_new, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+            & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age,&
+            & tot_melt, transpir, precip_rain, precip_snow, returnflow, irrigation, humrel, &
+            & vegstress, rsol, drysoil_frac, evapot, evapot_corr, shumdiag, litterhumdiag, soilcap, rest_id, hist_id, hist2_id) 
+       evap_bare_lim(:) = -un
+    ELSE
+       CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexveg, indexsoil, indexlayer, &
+            & temp_sol_new, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+            & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age,&
+            & tot_melt, transpir, precip_rain, precip_snow, returnflow, irrigation, humrel, &
+            & vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, &
+            & shumdiag, litterhumdiag, soilcap, soiltype, rest_id, hist_id, hist2_id)
+    ENDIF
+    ! 
+    ! computes last part of energy bilan
+    !
+    CALL enerbil_fusion (kjpindex, dtradia, tot_melt, soilcap, temp_sol_new, fusion)
+
+    ! 
+    ! computes condveg
+    !
+    CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index,&
+         & lalo, neighbours, resolution, contfrac, veget, veget_max, frac_nobio, totfrac_nobio, &
+         & zlev, snow, snow_age, snow_nobio, snow_nobio_age, &
+         & drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, soiltype, rest_id, hist_id, hist2_id)
+    ! 
+    ! computes Soil Thermodynamic
+    !
+    CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, indexgrnd, &
+         & temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id) 
+
+    !
+    ! If we chose to route the water then we call the module. Else variables
+    ! are set to zero.
+    ! 
+    !
+    IF ( river_routing .AND. nbp_glo .GT. 1) THEN
+       CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, myfalse, index, &
+            & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, runoff, &
+            & drainage, evapot_corr, precip_rain, humrel, &
+            & stempdiag, returnflow, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
+       !       returnflow(:) = returnflow(:) * 100.
+    ELSE
+       riverflow(:) = zero
+       coastalflow(:) = zero
+       returnflow(:) = zero
+       irrigation(:) = zero
+    ENDIF
+
+
+    !
+    ! computes slow variables
+    ! ok_co2 and ok_stomate are interpreted as flags that determine whether the
+    !   forcing files are written.
+    !
+    CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+         ldrestart_read, myfalse, control%ok_co2, control%ok_stomate, &
+         index, indexveg, lalo, neighbours, resolution, contfrac, soiltype, &
+         t2mdiag, t2mdiag, temp_sol, stempdiag, &
+         vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
+         deadleaf_cover, &
+         assim_param, &
+         lai, height, veget, frac_nobio, veget_max, totfrac_nobio, qsintmax, &
+         rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+         co2_flux)
+
+    !
+    ! call swap from new computed variables  
+    !
+    CALL sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
+    !
+    ! Write the internal variables into the output fields
+    !
+    z0_out(:) = z0(:)
+    emis_out(:) = emis(:)
+    albedo_out(:,:) = albedo(:,:) 
+    qsurf_out(:) = qsurf(:)
+    !
+    ! Writing the global variables on the history tape
+    !
+    !
+    IF ( .NOT. almaoutput ) THEN
+       CALL histwrite(hist_id, 'beta', kjit, vbeta, kjpindex, index)
+       CALL histwrite(hist_id, 'z0', kjit, z0, kjpindex, index)
+       CALL histwrite(hist_id, 'roughheight', kjit, roughheight, kjpindex, index)
+       CALL histwrite(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+       CALL histwrite(hist_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'subli', kjit, vevapsno, kjpindex, index)
+       CALL histwrite(hist_id, 'evapnu', kjit, vevapnu, kjpindex, index)
+       CALL histwrite(hist_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
+       CALL histwrite(hist_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'vbeta4', kjit, vbeta4, kjpindex, index)    
+       CALL histwrite(hist_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
+       CALL histwrite(hist_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'rsol', kjit, rsol, kjpindex, index)
+       CALL histwrite(hist_id, 'snow', kjit, snow, kjpindex, index)
+       CALL histwrite(hist_id, 'snowage', kjit, snow_age, kjpindex, index)
+       CALL histwrite(hist_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
+       CALL histwrite(hist_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
+       CALL histwrite(hist_id, 'soiltype',  kjit, soiltype, kjpindex*nstm, indexsoil)
+       IF ( control%ok_co2 ) THEN
+          CALL histwrite(hist_id, 'vbetaco2', kjit, vbetaco2, kjpindex*nvm, indexveg)    
+          CALL histwrite(hist_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
+          CALL histwrite(hist_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)    
+       ENDIF
+       IF ( control%ok_stomate ) THEN
+          CALL histwrite(hist_id, 'nee', kjit, co2_flux, kjpindex*nvm, indexveg)    
+       ENDIF
+
+       histvar(:)=SUM(vevapwet(:,:),dim=2)/one_day
+       CALL histwrite(hist_id, 'evspsblveg', kjit, histvar, kjpindex, index)
+
+       histvar(:)=(vevapnu(:)+vevapsno(:))/one_day
+       CALL histwrite(hist_id, 'evspsblsoi', kjit, histvar, kjpindex, index)
+
+       histvar(:)=SUM(transpir(:,:),dim=2)/one_day
+       CALL histwrite(hist_id, 'tran', kjit, histvar, kjpindex, index)
+
+       histvar(:)=SUM(veget_max(:,2:9),dim=2)*100*contfrac(:)
+       CALL histwrite(hist_id, 'treeFrac', kjit, histvar, kjpindex, index)
+
+       histvar(:)=SUM(veget_max(:,10:11),dim=2)*100*contfrac(:)
+       CALL histwrite(hist_id, 'grassFrac', kjit, histvar, kjpindex, index)
+
+       histvar(:)=SUM(veget_max(:,12:13),dim=2)*100*contfrac(:)
+       CALL histwrite(hist_id, 'cropFrac', kjit, histvar, kjpindex, index)
+
+       histvar(:)=veget_max(:,1)*100*contfrac(:)
+       CALL histwrite(hist_id, 'baresoilFrac', kjit, histvar, kjpindex, index)
+
+       histvar(:)=SUM(frac_nobio(:,1:nnobio),dim=2)*100*contfrac(:)
+       CALL histwrite(hist_id, 'residualFrac', kjit, histvar, kjpindex, index)
+
+    ELSE
+       CALL histwrite(hist_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+       CALL histwrite(hist_id, 'Qf', kjit, fusion, kjpindex, index)
+       CALL histwrite(hist_id, 'SWE', kjit, snow, kjpindex, index)
+       CALL histwrite(hist_id, 'ESoil', kjit, vevapnu, kjpindex, index)
+       CALL histwrite(hist_id, 'TVeg', kjit, transpir, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'ECanop', kjit, vevapwet, kjpindex*nvm, indexveg)
+       CALL histwrite(hist_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
+       CALL histwrite(hist_id, 'SnowFrac', kjit, vbeta1, kjpindex, index)
+       IF ( control%ok_co2 ) THEN
+          CALL histwrite(hist_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
+       ENDIF
+       IF ( control%ok_stomate ) THEN
+             CALL histwrite(hist_id, 'NEE', kjit, co2_flux, kjpindex*nvm, indexveg)    
+       ENDIF
+    ENDIF
+    !
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite(hist2_id, 'tsol_rad', kjit, tsol_rad, kjpindex, index)
+          CALL histwrite(hist2_id, 'qsurf', kjit, qsurf, kjpindex, index)
+          CALL histwrite(hist2_id, 'albedo', kjit, albedo, kjpindex*2, indexalb)
+          CALL histwrite(hist2_id, 'emis', kjit, emis, kjpindex, index)
+          !
+          CALL histwrite(hist2_id, 'beta', kjit, vbeta, kjpindex, index)
+          CALL histwrite(hist2_id, 'z0', kjit, z0, kjpindex, index)
+          CALL histwrite(hist2_id, 'roughheight', kjit, roughheight, kjpindex, index)
+          CALL histwrite(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+          CALL histwrite(hist2_id, 'lai', kjit, lai, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'subli', kjit, vevapsno, kjpindex, index)
+          CALL histwrite(hist2_id, 'vevapnu', kjit, vevapnu, kjpindex, index)
+          CALL histwrite(hist2_id, 'transpir', kjit, transpir, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'inter', kjit, vevapwet, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'vbeta1', kjit, vbeta1, kjpindex, index)
+          CALL histwrite(hist2_id, 'vbeta2', kjit, vbeta2, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'vbeta3', kjit, vbeta3, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'vbeta4', kjit, vbeta4, kjpindex, index)    
+          CALL histwrite(hist2_id, 'drysoil_frac', kjit, drysoil_frac, kjpindex, index)
+          CALL histwrite(hist2_id, 'rveget', kjit, rveget, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'rsol', kjit, rsol, kjpindex, index)
+          CALL histwrite(hist2_id, 'snow', kjit, snow, kjpindex, index)
+          CALL histwrite(hist2_id, 'snowage', kjit, snow_age, kjpindex, index)
+          CALL histwrite(hist2_id, 'snownobio', kjit, snow_nobio, kjpindex*nnobio, indexnobio)
+          CALL histwrite(hist2_id, 'snownobioage', kjit, snow_nobio_age, kjpindex*nnobio, indexnobio)
+          CALL histwrite(hist2_id, 'soiltype',  kjit, soiltype, kjpindex*nstm, indexsoil)
+          IF ( control%ok_co2 ) THEN
+             CALL histwrite(hist2_id, 'vbetaco2', kjit, vbetaco2, kjpindex*nvm, indexveg)    
+             CALL histwrite(hist2_id, 'gpp', kjit, gpp, kjpindex*nvm, indexveg)
+             CALL histwrite(hist2_id, 'cimean', kjit, cimean, kjpindex*nvm, indexveg)    
+          ENDIF
+          IF ( control%ok_stomate ) THEN
+             CALL histwrite(hist2_id, 'nee', kjit, co2_flux, kjpindex*nvm, indexveg)    
+          ENDIF
+       ELSE
+          CALL histwrite(hist2_id, 'vegetfrac', kjit, veget, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'maxvegetfrac', kjit, veget_max, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'nobiofrac', kjit, frac_nobio, kjpindex*nnobio, indexnobio)
+          CALL histwrite(hist2_id, 'Qf', kjit, fusion, kjpindex, index)
+          CALL histwrite(hist2_id, 'SWE', kjit, snow, kjpindex, index)
+          CALL histwrite(hist2_id, 'ESoil', kjit, vevapnu, kjpindex, index)
+          CALL histwrite(hist2_id, 'TVeg', kjit, transpir, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'ECanop', kjit, vevapwet, kjpindex*nvm, indexveg)
+          CALL histwrite(hist2_id, 'ACond', kjit, tq_cdrag, kjpindex, index)
+          CALL histwrite(hist2_id, 'SnowFrac', kjit, vbeta1, kjpindex, index)
+          IF ( control%ok_co2 ) THEN
+             CALL histwrite(hist2_id, 'GPP', kjit, gpp, kjpindex*nvm, indexveg)
+          ENDIF
+          IF ( control%ok_stomate ) THEN
+             CALL histwrite(hist2_id, 'NEE', kjit, co2_flux, kjpindex*nvm, indexveg)    
+          ENDIF
+       ENDIF
+    ENDIF
+    !
+    ! prepares restart file for the next simulation from SECHIBA and from other modules
+    !
+    IF (ldrestart_write) THEN
+
+       IF (long_print) WRITE (numout,*) ' we have to write a restart file '
+
+       ! 
+       ! call diffuco_main to write restart files
+       !
+
+       CALL diffuco_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, u, v, &
+! Ajout Nathalie - Juin 2006 - passage q2m/t2m pour calcul Rveget
+!           & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, pb ,  &
+            & zlev, z0, roughheight, temp_sol, temp_air, rau, tq_cdrag, qsurf, qair, q2m, t2m, pb ,  &
+            & rsol, evap_bare_lim, evapot, snow, frac_nobio, snow_nobio, totfrac_nobio, &
+            & swnet, swdown, ccanopy, humrel, veget, veget_max, lai, qsintveg, qsintmax, assim_param, &
+            & vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, rveget, cimean, rest_id, hist_id, hist2_id)
+
+       ! 
+       ! call energy bilan to write restart files
+       !
+       CALL enerbil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, &
+            & index, zlev, lwdown, swnet, epot_air, temp_air, u, v, petAcoef, petBcoef,&
+            & qair, peqAcoef, peqBcoef, pb, rau, vbeta, valpha, vbeta1, vbeta2, vbeta3, vbeta4, vbetaco2, &
+            & cimean, ccanopy, emis, soilflx, soilcap, tq_cdrag, humrel, fluxsens, fluxlat, &
+            & vevapp, transpir, gpp, vevapnu, vevapwet, vevapsno, t2mdiag, temp_sol, tsol_rad, &
+            & temp_sol_new, qsurf, evapot, evapot_corr, rest_id, hist_id, hist2_id) 
+
+       !
+       ! call hydrologie to write restart files
+       !
+       IF ( .NOT. hydrol_cwrr ) THEN
+          CALL hydrolc_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, &
+               & temp_sol_new, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+               & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age,&
+               & tot_melt, transpir, precip_rain, precip_snow, returnflow, irrigation, &
+               & humrel, vegstress, rsol, drysoil_frac, evapot, evapot_corr, shumdiag, litterhumdiag, soilcap, &
+               & rest_id, hist_id, hist2_id)
+          evap_bare_lim(:) = -un
+       ELSE
+          CALL hydrol_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexveg, indexsoil, indexlayer, &
+               & temp_sol_new, runoff, drainage, frac_nobio, totfrac_nobio, vevapwet, veget, veget_max,&
+               & qsintmax, qsintveg, vevapnu, vevapsno, snow, snow_age, snow_nobio, snow_nobio_age,&
+               & tot_melt, transpir, precip_rain, precip_snow, returnflow, irrigation, humrel, &
+               & vegstress, drysoil_frac, evapot, evapot_corr, evap_bare_lim, &
+               & shumdiag, litterhumdiag, soilcap, soiltype, rest_id, hist_id, hist2_id)
+          rsol(:) = -un
+       ENDIF
+       ! 
+       ! call condveg to write restart files
+       !
+       CALL condveg_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
+            & lalo, neighbours, resolution, contfrac, veget, veget_max, frac_nobio, totfrac_nobio, &
+            & zlev, snow, snow_age, snow_nobio, snow_nobio_age, &
+            & drysoil_frac, height, deadleaf_cover, emis, albedo, z0, roughheight, soiltype, rest_id, hist_id, hist2_id)
+
+       ! 
+       ! call Soil Thermodynamic to write restart files
+       !
+       CALL thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexgrnd, &
+            & temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id) 
+
+       !
+       ! If we chose to route the water then we call the module. Else variables
+       ! are set to zero.
+       ! 
+       !
+       IF ( river_routing .AND. nbp_glo .GT. 1) THEN
+          CALL routing_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, &
+               & lalo, neighbours, resolution, contfrac, totfrac_nobio, veget_max, runoff, &
+               & drainage, evapot_corr, precip_rain, humrel, &
+               & stempdiag, returnflow, irrigation, riverflow, coastalflow, rest_id, hist_id, hist2_id)
+       ELSE
+          riverflow(:) = zero
+          coastalflow(:) = zero
+          returnflow(:) = zero
+          irrigation(:) = zero
+       ENDIF
+
+       !
+       ! call slowproc_main to write restart files
+       !
+
+       CALL slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+            ldrestart_read, ldrestart_write, control%ok_co2, control%ok_stomate, &
+            index, indexveg, lalo, neighbours, resolution, contfrac, soiltype, &
+            t2mdiag, t2mdiag, temp_sol, stempdiag, &
+            vegstress, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
+            deadleaf_cover, &
+            assim_param, &
+            lai, height, veget, frac_nobio, veget_max, totfrac_nobio, qsintmax, &
+            rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+            co2_flux)
+
+
+       var_name= 'shumdiag'  
+       CALL restput_p(rest_id, var_name, nbp_glo,   nbdl, 1, kjit,  shumdiag, 'scatter',  nbp_glo, index_g)
+
+       var_name= 'runoff'  
+       CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  runoff, 'scatter',  nbp_glo, index_g)
+       var_name= 'drainage'  
+       CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  drainage, 'scatter',  nbp_glo, index_g)
+    END IF
+
+    IF (long_print) WRITE (numout,*) ' sechiba_main done '
+
+  END SUBROUTINE sechiba_main
+
+  !! Initialisation for SECHIBA processes
+  !! - does dynamic allocation for local arrays
+  !! - reads _restart_ file or set initial values to a raisonable value
+  !! - reads initial map
+  !!
+  SUBROUTINE sechiba_init (kjit, ldrestart_read, kjpij, kjpindex, index, rest_id, control_in, lalo)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                         :: kjit               !! Time step number 
+    LOGICAL,INTENT (in)                                :: ldrestart_read     !! Logical for restart file to read
+    INTEGER(i_std), INTENT (in)                         :: kjpij              !! Size of full domaine
+    INTEGER(i_std), INTENT (in)                         :: kjpindex           !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: index              !! Indeces of the points on the map
+    INTEGER(i_std), INTENT (in)                         :: rest_id            !! _Restart_ file identifier 
+    TYPE(control_type), INTENT(in)                     :: control_in         !! Flags that (de)activate parts of the model
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)     :: lalo               !! Geographical coordinates
+    ! output scalar 
+    ! output fields
+
+    ! local declaration
+    INTEGER(i_std)                                :: ier, ji, jv
+    !
+    ! initialisation
+    !
+    IF (l_first_sechiba) THEN 
+       l_first_sechiba=.FALSE.
+    ELSE 
+       WRITE (numout,*) ' l_first_sechiba false . we stop '
+       STOP 'sechiba_init'
+    ENDIF
+
+    ! 1. make dynamic allocation with good dimension
+
+    ! 1.0 The 3D vegetation indexation table 
+
+    ALLOCATE (indexveg(kjpindex*nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexveg allocation. We stop. We need kjpindex words = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (indexsoil(kjpindex*nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexsoil allocation. We stop. We need kjpindex words = ',kjpindex*nstm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (indexnobio(kjpindex*nnobio),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexnobio allocation. We stop. We need kjpindex words = ',kjpindex*nnobio
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (indexgrnd(kjpindex*ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexgrnd allocation. We stop. We need kjpindex words = ',kjpindex*ngrnd
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (indexlayer(kjpindex*nslm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexlayer allocation. We stop. We need kjpindex words = ',kjpindex*nslm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (indexalb(kjpindex*2),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in indexalb allocation. We stop. We need kjpindex words = ',kjpindex*2
+       STOP 'sechiba_init'
+    END IF
+
+    ! 1.1 one dimension array allocation with restartable value
+
+    IF (long_print) WRITE (numout,*) 'Allocation of 1D variables. We need for each kjpindex words = ',kjpindex
+    ALLOCATE (snow(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in snow allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    snow(:) = undef_sechiba
+
+    ALLOCATE (snow_age(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in snow_age allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    snow_age(:) = undef_sechiba
+
+    ALLOCATE (drysoil_frac(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in drysoil_frac allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    drysoil_frac(:) = zero
+
+    ALLOCATE (rsol(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in rsol allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (evap_bare_lim(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in evap_bare_lim allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (evapot(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in evapot allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    evapot(:) = undef_sechiba
+
+    ALLOCATE (evapot_corr(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in evapot_corr allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (humrel(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in humrel allocation. We stop. we need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    humrel(:,:) = undef_sechiba
+
+    ALLOCATE (vegstress(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vegstress allocation. We stop. we need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    vegstress(:,:) = undef_sechiba
+
+    ALLOCATE (soiltype(kjpindex,nstm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in soiltype allocation. We stop. we need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    soiltype(:,:)=undef_sechiba
+
+    ALLOCATE (vbeta1(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbeta1 allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (vbeta4(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbeta4 allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (soilcap(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in soilcap allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (soilflx(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in soilflx allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (temp_sol(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in temp_sol allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    temp_sol(:) = undef_sechiba
+
+    ALLOCATE (qsurf(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in qsurf allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    qsurf(:) = undef_sechiba
+
+    ! 1.2 two dimensions array allocation with restartable value
+
+    ALLOCATE (qsintveg(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in qsintveg allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm,' = ',kjpindex*nvm 
+       STOP 'sechiba_init'
+    END IF
+    qsintveg(:,:) = undef_sechiba
+
+    ALLOCATE (vbeta2(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbeta2 allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (vbeta3(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbeta3 allocation. We stop.We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (vbetaco2(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbetaco2 allocation. We stop.We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (cimean(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in cimean allocation. We stop.We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (gpp(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in gpp allocation. We stop.We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+    gpp(:,:) = undef_sechiba
+
+    ALLOCATE (veget(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in veget allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+    veget(:,:)=undef_sechiba
+
+    ALLOCATE (veget_max(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in veget_max allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+    veget_max(:,:)=undef_sechiba
+
+    ALLOCATE (lai(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in lai allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+    lai(:,:)=undef_sechiba
+
+    ALLOCATE (height(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in height allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+    height(:,:)=undef_sechiba
+
+    ALLOCATE (frac_nobio(kjpindex,nnobio),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in frac_nobio allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    frac_nobio(:,:) = undef_sechiba
+
+    ALLOCATE (albedo(kjpindex,2),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in albedo allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (snow_nobio(kjpindex,nnobio),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in snow_nobio allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    snow_nobio(:,:) = undef_sechiba
+
+    ALLOCATE (snow_nobio_age(kjpindex,nnobio),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in snow_nobio_age allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    snow_nobio_age(:,:) = undef_sechiba
+
+    ALLOCATE (assim_param(kjpindex,nvm,npco2),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in assim_param allocation. We stop. We need kjpindex x nvm x npco2 words = ',&
+            & kjpindex,' x ' ,nvm,' x ',npco2, ' = ',kjpindex*nvm*npco2
+       STOP 'sechiba_init'
+    END IF
+
+    ! 1.3 one dimension array allocation 
+
+    ALLOCATE (vevapsno(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vevapsno allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (vevapnu(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vevapnu allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (t2mdiag(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in t2mdiag allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (totfrac_nobio(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in totfrac_nobio allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (runoff(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in runoff allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (drainage(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in drainage allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (returnflow(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in returnflow allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    returnflow(:) = zero
+
+    ALLOCATE (irrigation(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in irrigation allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+    irrigation(:) = zero
+
+    ALLOCATE (z0(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in z0 allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (roughheight(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in roughheight allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (emis(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in emis allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (tot_melt(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in tot_melt allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (valpha(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in valpha allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (vbeta(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vbeta allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (fusion(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in fusion allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (rau(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in rau allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (deadleaf_cover(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in deadleaf_cover allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (stempdiag(kjpindex, nbdl),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in stempdiag allocation. We stop. We need kjpindex*nbdl words = ',&
+            & kjpindex*nbdl
+       STOP 'sechiba_init'
+    END IF
+    ALLOCATE (co2_flux(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in co2_flux allocation. We stop. We need kjpindex*nvm words = ' ,kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+    co2_flux(:,:)=zero
+
+    ALLOCATE (shumdiag(kjpindex,nbdl),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in shumdiag allocation. We stop. We need kjpindex*nbdl words = ',&
+            & kjpindex*nbdl
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (litterhumdiag(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in litterhumdiag allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'sechiba_init'
+    END IF
+
+    ! 1.4 two dimensions array allocation
+
+    ALLOCATE (vevapwet(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in vevapwet allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (transpir(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in transpir allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (qsintmax(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in qsintmax allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm 
+       STOP 'sechiba_init'
+    END IF
+
+    ALLOCATE (rveget(kjpindex,nvm),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in rveget allocation. We stop. We need kjpindex x nvm words = ',&
+            & kjpindex,' x ' ,nvm, ' = ',kjpindex*nvm
+       STOP 'sechiba_init'
+    END IF
+
+    !
+    !  1.5  Get the indexing table for the vegetation fields. In SECHIBA we work on reduced grids but to store in the
+    !          full 3D filed vegetation variable we need another index table : indexveg, indexsoil, indexnobio and
+    !          indexgrnd
+    !
+    DO ji = 1, kjpindex
+       !
+       DO jv = 1, nvm
+          indexveg((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
+       ENDDO
+       !      
+       DO jv = 1, nstm
+          indexsoil((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
+       ENDDO
+       !      
+       DO jv = 1, nnobio
+          indexnobio((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
+       ENDDO
+       !
+       DO jv = 1, ngrnd
+          indexgrnd((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
+       ENDDO
+       !
+       DO jv = 1, nslm
+          indexlayer((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
+       ENDDO
+       !
+       DO jv = 1, 2
+          indexalb((jv-1)*kjpindex + ji) = INDEX(ji) + (jv-1)*kjpij
+       ENDDO
+       !
+    ENDDO
+
+    !
+    ! 2. restart value
+    !
+    ! open restart input file if needed
+    ! and read data from restart input file
+    !
+
+    IF (ldrestart_read) THEN
+
+       IF (long_print) WRITE (numout,*) ' we have to read a restart file for SECHIBA variables'
+       !
+       !   Read the default value that will be put into variable which are not in the restart file
+       !
+       CALL ioget_expval(val_exp)
+
+    ENDIF
+
+    !
+    river_routing = control_in%river_routing
+    hydrol_cwrr = control_in%hydrol_cwrr
+    !
+    ! 4. run control: store flags in a common variable
+    !
+
+    control%river_routing = control_in%river_routing
+    control%hydrol_cwrr = control_in%hydrol_cwrr
+    control%ok_co2 = control_in%ok_co2
+    control%ok_sechiba = control_in%ok_sechiba
+    control%ok_stomate = control_in%ok_stomate
+    control%ok_dgvm = control_in%ok_dgvm
+    control%ok_pheno = control_in%ok_pheno
+    control%stomate_watchout = control_in%stomate_watchout
+
+    IF (long_print) WRITE (numout,*) ' sechiba_init done '
+
+  END SUBROUTINE sechiba_init
+  !
+  !------------------------------------------------------------------
+  !
+  SUBROUTINE sechiba_clear (forcing_name,cforcing_name)
+
+    CHARACTER(LEN=100), INTENT(in)           :: forcing_name
+    CHARACTER(LEN=100), INTENT(in)           :: cforcing_name
+
+    !
+    ! initialisation
+    !
+    l_first_sechiba=.TRUE.
+
+    ! 1. Deallocate all dynamic variables
+
+    IF ( ALLOCATED (indexveg)) DEALLOCATE (indexveg)
+    IF ( ALLOCATED (indexsoil)) DEALLOCATE (indexsoil)
+    IF ( ALLOCATED (indexnobio)) DEALLOCATE (indexnobio)
+    IF ( ALLOCATED (indexgrnd)) DEALLOCATE (indexgrnd)
+    IF ( ALLOCATED (indexlayer)) DEALLOCATE (indexlayer)
+    IF ( ALLOCATED (indexalb)) DEALLOCATE (indexalb)
+    IF ( ALLOCATED (snow)) DEALLOCATE (snow)
+    IF ( ALLOCATED (snow_age)) DEALLOCATE (snow_age)
+    IF ( ALLOCATED (drysoil_frac)) DEALLOCATE (drysoil_frac)
+    IF ( ALLOCATED (rsol)) DEALLOCATE (rsol)
+    IF ( ALLOCATED (evap_bare_lim)) DEALLOCATE (evap_bare_lim)
+    IF ( ALLOCATED (evapot)) DEALLOCATE (evapot)
+    IF ( ALLOCATED (evapot_corr)) DEALLOCATE (evapot_corr)
+    IF ( ALLOCATED (humrel)) DEALLOCATE (humrel)
+    IF ( ALLOCATED (vegstress)) DEALLOCATE (vegstress)
+    IF ( ALLOCATED (soiltype)) DEALLOCATE (soiltype)
+    IF ( ALLOCATED (vbeta1)) DEALLOCATE (vbeta1)
+    IF ( ALLOCATED (vbeta4)) DEALLOCATE (vbeta4)
+    IF ( ALLOCATED (soilcap)) DEALLOCATE (soilcap)
+    IF ( ALLOCATED (soilflx)) DEALLOCATE (soilflx)
+    IF ( ALLOCATED (temp_sol)) DEALLOCATE (temp_sol)
+    IF ( ALLOCATED (qsurf)) DEALLOCATE (qsurf)
+    IF ( ALLOCATED (qsintveg)) DEALLOCATE (qsintveg)
+    IF ( ALLOCATED (vbeta2))  DEALLOCATE (vbeta2)
+    IF ( ALLOCATED (vbeta3)) DEALLOCATE (vbeta3)
+    IF ( ALLOCATED (vbetaco2)) DEALLOCATE (vbetaco2)
+    IF ( ALLOCATED (cimean)) DEALLOCATE (cimean)
+    IF ( ALLOCATED (gpp)) DEALLOCATE (gpp)
+    IF ( ALLOCATED (veget)) DEALLOCATE (veget)
+    IF ( ALLOCATED (veget_max)) DEALLOCATE (veget_max)
+    IF ( ALLOCATED (lai)) DEALLOCATE (lai)
+    IF ( ALLOCATED (height)) DEALLOCATE (height)
+    IF ( ALLOCATED (roughheight)) DEALLOCATE (roughheight)
+    IF ( ALLOCATED (frac_nobio)) DEALLOCATE (frac_nobio)
+    IF ( ALLOCATED (snow_nobio)) DEALLOCATE (snow_nobio)
+    IF ( ALLOCATED (snow_nobio_age)) DEALLOCATE (snow_nobio_age)
+    IF ( ALLOCATED (assim_param)) DEALLOCATE (assim_param)
+    IF ( ALLOCATED (vevapsno)) DEALLOCATE (vevapsno)
+    IF ( ALLOCATED (vevapnu)) DEALLOCATE (vevapnu)
+    IF ( ALLOCATED (t2mdiag)) DEALLOCATE (t2mdiag)
+    IF ( ALLOCATED (totfrac_nobio)) DEALLOCATE (totfrac_nobio)
+    IF ( ALLOCATED (runoff)) DEALLOCATE (runoff)
+    IF ( ALLOCATED (drainage)) DEALLOCATE (drainage)
+    IF ( ALLOCATED (returnflow)) DEALLOCATE (returnflow)
+    IF ( ALLOCATED (irrigation)) DEALLOCATE (irrigation)
+    IF ( ALLOCATED (tot_melt)) DEALLOCATE (tot_melt)
+    IF ( ALLOCATED (valpha)) DEALLOCATE (valpha)
+    IF ( ALLOCATED (vbeta)) DEALLOCATE (vbeta)
+    IF ( ALLOCATED (fusion)) DEALLOCATE (fusion)
+    IF ( ALLOCATED (rau)) DEALLOCATE (rau)
+    IF ( ALLOCATED (deadleaf_cover)) DEALLOCATE (deadleaf_cover)
+    IF ( ALLOCATED (stempdiag)) DEALLOCATE (stempdiag)
+    IF ( ALLOCATED (co2_flux)) DEALLOCATE (co2_flux)
+    IF ( ALLOCATED (shumdiag)) DEALLOCATE (shumdiag)
+    IF ( ALLOCATED (litterhumdiag)) DEALLOCATE (litterhumdiag)
+    IF ( ALLOCATED (vevapwet)) DEALLOCATE (vevapwet)
+    IF ( ALLOCATED (transpir)) DEALLOCATE (transpir)
+    IF ( ALLOCATED (qsintmax)) DEALLOCATE (qsintmax)
+    IF ( ALLOCATED (rveget)) DEALLOCATE (rveget)
+    ! 2. clear all modules
+    CALL slowproc_clear 
+    CALL diffuco_clear 
+    CALL enerbil_clear  
+    IF ( hydrol_cwrr ) THEN
+       CALL hydrol_clear 
+    ELSE
+       CALL hydrolc_clear  
+    ENDIF
+    CALL condveg_clear 
+    CALL thermosoil_clear
+    CALL routing_clear
+    !3. give name to next block
+    stomate_forcing_name=forcing_name
+    stomate_Cforcing_name=Cforcing_name
+
+  END SUBROUTINE sechiba_clear
+
+  !! SECHIBA's variables initialisation
+  !! called every time step
+  !!
+  SUBROUTINE sechiba_var_init (kjpindex, rau, pb, temp_air) 
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                    :: kjpindex           !! Domain dimension
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: pb                 !! Lowest level pressure
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)  :: temp_air           !! Air temperature
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out) :: rau                !! Density
+
+    ! local declaration
+    INTEGER(i_std)                                :: ji
+
+    !
+    ! initialisation
+    !
+
+    !
+    ! 1. calcul of rau: air density
+    !
+
+    DO ji = 1,kjpindex
+       rau(ji) = pa_par_hpa * pb(ji) / (cte_molr*temp_air(ji))
+    END DO
+
+    IF (long_print) WRITE (numout,*) ' sechiba_var_init done '
+
+  END SUBROUTINE sechiba_var_init
+
+  !!
+  !! Swap new fields to previous fields
+  !!
+  SUBROUTINE sechiba_end (kjpindex, dtradia, temp_sol, temp_sol_new)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                       :: kjpindex           !! Domain dimension
+    REAL(r_std),INTENT (in)                           :: dtradia            !! Time step in seconds
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)     :: temp_sol_new       !! New soil temperature
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)    :: temp_sol           !! Soil temperature
+
+    !
+    ! swap 
+    !
+    temp_sol(:) = temp_sol_new(:)
+
+    IF (long_print) WRITE (numout,*) ' sechiba_end done '
+
+  END SUBROUTINE sechiba_end
+
+END MODULE sechiba
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba_io.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba_io.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba_io.f90	(revision 55)
@@ -0,0 +1,468 @@
+!! This subroutines initialize a variable or an array
+!! with a variable or an array of smaller rank
+!! - i is for integer interface - r for real interface
+!! - 0 is for a scalar - 1 for a 1D array - 2 for a 2D array
+!! Thee right routines is automatically called depending type of input variable
+!! This initialisation is done only if the value of input field is egal to val_exp
+!!
+!! If a key word is provided which is not equal to "NO_KEYWORD" or "NOKEYWORD" then
+!! we try to find the value to fill in in the configuration file.
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!!
+MODULE sechiba_io
+
+  USE defprec
+
+  USE constantes
+  USE constantes_veg
+  USE ioipsl
+  USE sechiba_io_p
+
+  IMPLICIT NONE
+
+  INTERFACE setvar
+    MODULE PROCEDURE i0setvar, i10setvar, i20setvar, i11setvar, i21setvar, i22setvar
+    MODULE PROCEDURE r0setvar, r10setvar, r20setvar, r11setvar, r21setvar, r22setvar, r30setvar
+  END INTERFACE
+
+!
+! mettre la l'interface des routines utilisees:
+!
+! restget/put/ini histbeg/def flinopen/close
+!
+
+LOGICAL, SAVE                  :: long_print_setvar=.FALSE.  !! change to true to have more information
+
+CONTAINS 
+
+
+!! Interface for integer scalar to scalar.
+SUBROUTINE i0setvar (var, val_exp, key_wd, val_put)
+
+  INTEGER(i_std), INTENT(inout)                   :: var                  !! Integer scalar to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), INTENT(in)                      :: val_put              !! Initial value to stored
+
+  INTEGER(i_std)                                  :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  IF (long_print_setvar) WRITE(numout,*) "i0setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( var == val_exp ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
+     var = val_tmp
+  END IF
+  
+END SUBROUTINE i0setvar
+
+
+!! Interface for initialising an 1D integer array with a scalar integer.
+SUBROUTINE i10setvar (var, val_exp, key_wd, val_put)
+
+  INTEGER(i_std), DIMENSION(:), INTENT(inout)     :: var                  !! 1D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+  
+  INTEGER(i_std)                                  :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar) WRITE(numout,*) "i10setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:) == val_exp ) ) THEN
+     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
+     var(:) = val_tmp
+  END IF
+  
+END SUBROUTINE i10setvar
+
+
+!! Interface for initialising an 1D array integer with an other 1D array integer.
+SUBROUTINE i11setvar (var, val_exp, key_wd, val_put)
+  
+  INTEGER(i_std), DIMENSION(:), INTENT(inout)     :: var                 !! 1D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), DIMENSION(:), INTENT(in)        :: val_put             !! 1D integer array to stored
+
+  INTEGER(i_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  IF (long_print_setvar) WRITE(numout,*) "i11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF ( ALL( var(:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
+     var(:) = val_tmp (:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE i11setvar
+
+
+!! Interface for initialising an 2D array integer with a scalar integer.
+SUBROUTINE i20setvar (var, val_exp, key_wd, val_put)
+  
+  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+
+  INTEGER(i_std)                                  :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  !
+  ! this subroutine set val_put value to var if var is constant
+  ! 
+  !
+  IF (long_print_setvar) WRITE(numout,*) "i20setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:,:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
+     var(:,:) = val_tmp
+  END IF
+  
+END SUBROUTINE i20setvar
+
+
+!! Interface for initialising an 2D array integer with an 1D array integer.
+!! Row or column depending size of 1D array to stored.
+!!
+!! example: 1D 1,2,3     2D is 1, 2, 3,
+!!                             1, 2, 3
+!!
+!!
+!! example: 1D 1,2,3     2D is 1, 1,
+!!                             2, 2,
+!!                             3, 3
+!!
+SUBROUTINE i21setvar (var, val_exp, key_wd, val_put)
+  
+  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), DIMENSION(:), INTENT(in)        :: val_put              !! 1D integer array to stored
+  
+  INTEGER(i_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  ! test if the 1D array dimension is compatible with first or second 
+  ! dimension of the 2D array
+
+  IF (long_print_setvar) WRITE(numout,*) "i21setvar :", key_wd, val_exp, val_put
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF (SIZE(val_put)==SIZE(var,1)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
+      !                                1., 2., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+         var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
+      END IF
+  ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 1.,
+      !                                2., 2.,
+      !                                3., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+         var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
+      END IF
+  ELSE 
+      WRITE(numout,*) ' incompatible dimension var and val_put'
+      WRITE(numout,*) ' var     ', SIZE(var,1), SIZE(var,2)
+      WRITE(numout,*) ' val_put ', SIZE(val_put)
+      STOP 'setvar'
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE i21setvar
+
+!! Interface for initialising an 2D array integer with an other 2D array integer.
+SUBROUTINE i22setvar (var, val_exp, key_wd, val_put)
+  
+  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                 !! 2D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd              !! The Key word we will look for
+  INTEGER(i_std), DIMENSION(:,:), INTENT(in)      :: val_put             !! 2D integer array to stored
+
+  INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)     :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  IF (long_print_setvar) WRITE(numout,*) "i21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
+
+  ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
+  val_tmp(:,:) = val_put(:,:)
+
+  IF ( ALL(var(:,:) == val_exp ) ) THEN
+     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+     var(:,:) = val_tmp(:,:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE i22setvar
+
+
+!! Interface for scalar to scalar real
+SUBROUTINE r0setvar (var, val_exp, key_wd, val_put)
+  
+  REAL(r_std), INTENT(inout)                   :: var                  !! Real scalar to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Initial value to stored
+  
+  REAL(r_std)                                  :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar) WRITE(numout,*) "r0setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( var==val_exp ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+     var = val_tmp
+  END IF
+  
+END SUBROUTINE r0setvar
+
+
+!! Interface for initialising an 1D real array with a scalar real.
+SUBROUTINE r10setvar (var, val_exp, key_wd, val_put)
+  
+  REAL(r_std), DIMENSION(:), INTENT(inout)     :: var                  !! 1D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+   
+  REAL(r_std)                                  :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+ 
+  IF (long_print_setvar) WRITE(numout,*) "r10setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+     var(:) = val_tmp
+  END IF
+  
+END SUBROUTINE r10setvar
+
+
+!! Interface for initialising an 1D array real with an other 1D array real.
+SUBROUTINE r11setvar (var, val_exp, key_wd, val_put)
+  
+  REAL(r_std), DIMENSION(:), INTENT(inout)     :: var                 !! 1D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd              !! The Key word we will look for
+  REAL(r_std), DIMENSION(:), INTENT(in)        :: val_put             !! 1D integer array to stored
+
+  REAL(r_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+   
+  IF (long_print_setvar) WRITE(numout,*) "r11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF ( ALL( var(:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+     var(:) = val_tmp (:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE r11setvar
+
+
+!! Interface for initialising an 2D array real with a scalar real.
+SUBROUTINE r20setvar (var, val_exp, key_wd, val_put)
+  
+  ! interface for scalar to 2D array real
+
+  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd                  !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+ 
+  REAL(r_std)                                  :: val_tmp  
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+ 
+  IF (long_print_setvar) WRITE(numout,*) "r20setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:,:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd,  val_tmp)
+     var(:,:) = val_tmp
+  END IF
+  
+END SUBROUTINE r20setvar
+
+
+!! Interface for initialising an 2D array real with an 1D array real.
+!! Row or column depending size of 1D array to stored.
+!!
+!! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
+!!                                1., 2., 3.
+!!
+!!
+!! example: 1D 1.,2.,3.     2D is 1., 1.,
+!!                                2., 2.,
+!!                                3., 3.
+!!
+SUBROUTINE r21setvar (var, val_exp, key_wd, val_put)
+  
+  ! interface for 1D array to 2D array real
+
+  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
+  REAL(r_std), DIMENSION(:), INTENT(in)        :: val_put              !! 1D real array to stored
+
+  REAL(r_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  ! test if the 1D array dimension is compatible with first or second 
+  ! dimension of the 2D array
+
+  IF (long_print_setvar) WRITE(numout,*) "r21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF (SIZE(val_put)==SIZE(var,1)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
+      !                                1., 2., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+         var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
+      END IF
+  ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 1.,
+      !                                2., 2.,
+      !                                3., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+         var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
+      END IF
+  ELSE 
+      WRITE(numout,*) ' incompatible dimension var and val_put'
+      WRITE(numout,*) ' var     ', SIZE(var,1), SIZE(var,2)
+      WRITE(numout,*) ' val_put ', SIZE(val_put)
+      STOP 'setvar'
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE r21setvar
+
+
+!! Interface for initialising an 2D array real with an other 2D array real. 
+SUBROUTINE r22setvar (var, val_exp, key_wd, val_put)
+  
+  ! interface for 2D array to 2D array real
+
+  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                 !! 2D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd              !! The Key word we will look for
+  REAL(r_std), DIMENSION(:,:), INTENT(in)      :: val_put             !! 2D integer array to stored
+
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar) WRITE(numout,*) "r22setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
+
+  ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
+  val_tmp(:,:) = val_put(:,:)
+
+  IF ( ALL( var(:,:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+     var(:,:) = val_tmp(:,:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE r22setvar
+
+!! Interface for initialising an 3D array real with a scalar real.
+SUBROUTINE r30setvar (var, val_exp, key_wd, val_put)
+
+  ! interface for scalar to 3D array real
+
+  REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: var                  !! 3D integer array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+
+  REAL(r_std)                                  :: val_tmp 
+  INTEGER(i_std)                              :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar) WRITE(numout,*) 'r30setvar',val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:,:,:) == val_exp ) ) THEN
+     IF ( is_key <= 0 ) CALL getin(key_wd, val_tmp)
+     var(:,:,:) = val_tmp
+  END IF
+
+END SUBROUTINE r30setvar
+
+END MODULE sechiba_io
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba_io_p.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba_io_p.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/sechiba_io_p.f90	(revision 55)
@@ -0,0 +1,523 @@
+!! This subroutines initialize a variable or an array
+!! with a variable or an array of smaller rank
+!! - i is for integer interface - r for real interface
+!! - 0 is for a scalar - 1 for a 1D array - 2 for a 2D array
+!! Thee right routines is automatically called depending type of input variable
+!! This initialisation is done only if the value of input field is egal to val_exp
+!!
+!! If a key word is provided which is not equal to "NO_KEYWORD" or "NOKEYWORD" then
+!! we try to find the value to fill in in the configuration file.
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!!
+MODULE sechiba_io_p
+
+  USE defprec
+
+  USE constantes
+  USE constantes_veg
+  USE ioipsl
+  USE parallel
+  
+  IMPLICIT NONE
+
+  INTERFACE setvar_p
+    MODULE PROCEDURE i0setvar_p, i10setvar_p, i20setvar_p, i11setvar_p, i21setvar_p, i22setvar_p
+    MODULE PROCEDURE r0setvar_p, r10setvar_p, r20setvar_p, r11setvar_p, r21setvar_p, r22setvar_p, r30setvar_p
+  END INTERFACE
+
+!
+! mettre la l'interface des routines utilisees:
+!
+! restget/put/ini histbeg/def flinopen/close
+!
+
+LOGICAL, SAVE                  :: long_print_setvar_p=.FALSE.  !! change to true to have more information
+
+CONTAINS 
+
+!! pour déclancher les restarts rajoutés avec un paramètre externe
+FUNCTION ok_var ( varname )
+  CHARACTER(LEN=*), INTENT(IN) :: varname
+  LOGICAL ok_var
+  ok_var=.FALSE.
+  CALL getin_p(varname, ok_var)
+END FUNCTION ok_var
+
+!! Interface for integer scalar to scalar.
+SUBROUTINE i0setvar_p (var, val_exp, key_wd, val_put)
+
+  INTEGER(i_std), INTENT(inout)                   :: var                  !! Integer scalar to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), INTENT(in)                      :: val_put              !! Initial value to stored
+
+  INTEGER(i_std)                                  :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  IF (long_print_setvar_p) WRITE (numout,*) "i0setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( var == val_exp ) THEN 
+     IF ( is_key <= 0 ) THEN
+        CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var = val_tmp
+  END IF
+  
+END SUBROUTINE i0setvar_p
+
+
+!! Interface for initialising an 1D integer array with a scalar integer.
+SUBROUTINE i10setvar_p (var, val_exp, key_wd, val_put)
+
+  INTEGER(i_std), DIMENSION(:), INTENT(inout)     :: var                  !! 1D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+  
+  INTEGER(i_std)                                  :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar_p) WRITE (numout,*) "i10setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:) == val_exp ) ) THEN
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:) = val_tmp
+  END IF
+  
+END SUBROUTINE i10setvar_p
+
+
+!! Interface for initialising an 1D array integer with an other 1D array integer.
+SUBROUTINE i11setvar_p (var, val_exp, key_wd, val_put, is_grid)
+  
+  INTEGER(i_std), DIMENSION(:), INTENT(inout)     :: var                 !! 1D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), DIMENSION(:), INTENT(in)        :: val_put             !! 1D integer array to stored
+  LOGICAL,        OPTIONAL                        :: is_grid              !! Parameter present indicates a setvar for a grid variable 
+
+  INTEGER(i_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp_g
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  IF (long_print_setvar_p) WRITE (numout,*) "i11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF ( ALL( var(:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) THEN
+        IF (PRESENT(is_grid) ) THEN
+           IF (is_root_prc) &
+              ALLOCATE( val_tmp_g(nbp_glo) )
+           CALL gather( val_tmp,val_tmp_g )
+           IF (is_root_prc) &
+              CALL getin(key_wd,  val_tmp_g)
+           CALL scatter( val_tmp,val_tmp_g )
+           IF (is_root_prc) &
+              DEALLOCATE( val_tmp_g )
+        ELSE
+           CALL getin_p(key_wd,  val_tmp)
+        ENDIF
+     ENDIF
+     var(:) = val_tmp (:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE i11setvar_p
+
+
+!! Interface for initialising an 2D array integer with a scalar integer.
+SUBROUTINE i20setvar_p (var, val_exp, key_wd, val_put)
+  
+  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+
+  INTEGER(i_std)                                  :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  !
+  ! this subroutine set val_put value to var if var is constant
+  ! 
+  !
+  IF (long_print_setvar_p) WRITE (numout,*) "i20setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:,:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:,:) = val_tmp
+  END IF
+  
+END SUBROUTINE i20setvar_p
+
+
+!! Interface for initialising an 2D array integer with an 1D array integer.
+!! Row or column depending size of 1D array to stored.
+!!
+!! example: 1D 1,2,3     2D is 1, 2, 3,
+!!                             1, 2, 3
+!!
+!!
+!! example: 1D 1,2,3     2D is 1, 1,
+!!                             2, 2,
+!!                             3, 3
+!!
+SUBROUTINE i21setvar_p (var, val_exp, key_wd, val_put, is_grid)
+  
+  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  INTEGER(i_std), DIMENSION(:), INTENT(in)        :: val_put              !! 1D integer array to stored
+  LOGICAL,        OPTIONAL                        :: is_grid              !! Parameter present indicates a setvar for a grid variable 
+  
+  INTEGER(i_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  ! test if the 1D array dimension is compatible with first or second 
+  ! dimension of the 2D array
+
+  IF (long_print_setvar_p) WRITE (numout,*) "i21setvar :", key_wd, val_exp, val_put
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF (SIZE(val_put)==SIZE(var,1)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
+      !                                1., 2., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) THEN
+           CALL getin_p(key_wd,  val_tmp)
+         ENDIF
+         var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
+      END IF
+  ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 1.,
+      !                                2., 2.,
+      !                                3., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) THEN
+           CALL getin_p(key_wd,  val_tmp)
+         ENDIF
+         var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
+      END IF
+  ELSE 
+      WRITE (numout,*) ' incompatible dimension var and val_put'
+      WRITE (numout,*) ' var     ', SIZE(var,1), SIZE(var,2)
+      WRITE (numout,*) ' val_put ', SIZE(val_put)
+      STOP 'setvar'
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE i21setvar_p
+
+!! Interface for initialising an 2D array integer with an other 2D array integer.
+SUBROUTINE i22setvar_p (var, val_exp, key_wd, val_put, is_grid)
+  
+  INTEGER(i_std), DIMENSION(:,:), INTENT(inout)   :: var                 !! 2D integer array to modify
+  INTEGER(i_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd              !! The Key word we will look for
+  INTEGER(i_std), DIMENSION(:,:), INTENT(in)      :: val_put             !! 2D integer array to stored
+  LOGICAL,        OPTIONAL                        :: is_grid              !! Parameter present indicates a setvar for a grid variable 
+
+  INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:)     :: val_tmp
+  INTEGER(i_std)                                  :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  IF (long_print_setvar_p) WRITE (numout,*) "i21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
+
+  ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
+  val_tmp(:,:) = val_put(:,:)
+
+  IF ( ALL(var(:,:) == val_exp ) ) THEN
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:,:) = val_tmp(:,:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE i22setvar_p
+
+
+!! Interface for scalar to scalar real
+SUBROUTINE r0setvar_p (var, val_exp, key_wd, val_put)
+  
+  REAL(r_std), INTENT(inout)                   :: var                  !! Real scalar to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Initial value to stored
+  
+  REAL(r_std)                                  :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar_p) WRITE (numout,*) "r0setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( var==val_exp ) THEN 
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var = val_tmp
+  END IF
+  
+END SUBROUTINE r0setvar_p
+
+
+!! Interface for initialising an 1D real array with a scalar real.
+SUBROUTINE r10setvar_p (var, val_exp, key_wd, val_put)
+  
+  REAL(r_std), DIMENSION(:), INTENT(inout)     :: var                  !! 1D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+   
+  REAL(r_std)                                  :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+ 
+  IF (long_print_setvar_p) WRITE (numout,*) "r10setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:) = val_tmp
+  END IF
+  
+END SUBROUTINE r10setvar_p
+
+
+!! Interface for initialising an 1D array real with an other 1D array real.
+SUBROUTINE r11setvar_p (var, val_exp, key_wd, val_put, is_grid)
+  
+  REAL(r_std), DIMENSION(:), INTENT(inout)     :: var                 !! 1D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd              !! The Key word we will look for
+  REAL(r_std), DIMENSION(:), INTENT(in)        :: val_put             !! 1D integer array to stored
+  LOGICAL,        OPTIONAL                        :: is_grid              !! Parameter present indicates a setvar for a grid variable 
+
+  REAL(r_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+   
+  IF (long_print_setvar_p) WRITE (numout,*) "r11setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF ( ALL( var(:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:) = val_tmp (:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE r11setvar_p
+
+
+!! Interface for initialising an 2D array real with a scalar real.
+SUBROUTINE r20setvar_p (var, val_exp, key_wd, val_put)
+  
+  ! interface for scalar to 2D array real
+
+  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D integer array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd                  !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+ 
+  REAL(r_std)                                  :: val_tmp  
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+ 
+  IF (long_print_setvar_p) WRITE (numout,*) "r20setvar :", key_wd, val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:,:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:,:) = val_tmp
+  END IF
+  
+END SUBROUTINE r20setvar_p
+
+
+!! Interface for initialising an 2D array real with an 1D array real.
+!! Row or column depending size of 1D array to stored.
+!!
+!! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
+!!                                1., 2., 3.
+!!
+!!
+!! example: 1D 1.,2.,3.     2D is 1., 1.,
+!!                                2., 2.,
+!!                                3., 3.
+!!
+SUBROUTINE r21setvar_p (var, val_exp, key_wd, val_put, is_grid)
+  
+  ! interface for 1D array to 2D array real
+
+  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                  !! 2D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd               !! The Key word we will look for
+  REAL(r_std), DIMENSION(:), INTENT(in)        :: val_put              !! 1D real array to stored
+  LOGICAL,        OPTIONAL                        :: is_grid              !! Parameter present indicates a setvar for a grid variable 
+
+  REAL(r_std), ALLOCATABLE,DIMENSION(:)        :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+  
+  ! test if the 1D array dimension is compatible with first or second 
+  ! dimension of the 2D array
+
+  IF (long_print_setvar_p) WRITE (numout,*) "r21setvar :", key_wd, val_exp, SIZE(val_put), val_put(1)
+
+  ALLOCATE(val_tmp(SIZE(val_put)))
+  val_tmp(:) = val_put(:)
+
+  IF (SIZE(val_put)==SIZE(var,1)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 2., 3.,
+      !                                1., 2., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) THEN
+           CALL getin_p(key_wd,  val_tmp)
+         ENDIF
+         var(:,:) = SPREAD(val_tmp(:),2,SIZE(var,1))
+      END IF
+  ELSEIF (SIZE(val_put)==SIZE(var,2)) THEN 
+      !
+      ! example: 1D 1.,2.,3.     2D is 1., 1.,
+      !                                2., 2.,
+      !                                3., 3.
+      !
+      IF ( ALL( var(:,:) == val_exp ) ) THEN 
+         IF ( is_key <= 0 ) THEN
+           CALL getin_p(key_wd,  val_tmp)
+         ENDIF
+         var(:,:) = SPREAD(val_tmp(:),1,SIZE(var,1))
+      END IF
+  ELSE 
+      WRITE (numout,*) ' incompatible dimension var and val_put'
+      WRITE (numout,*) ' var     ', SIZE(var,1), SIZE(var,2)
+      WRITE (numout,*) ' val_put ', SIZE(val_put)
+      STOP 'setvar'
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE r21setvar_p
+
+
+!! Interface for initialising an 2D array real with an other 2D array real. 
+SUBROUTINE r22setvar_p (var, val_exp, key_wd, val_put, is_grid)
+  
+  ! interface for 2D array to 2D array real
+
+  REAL(r_std), DIMENSION(:,:), INTENT(inout)   :: var                 !! 2D real array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp             !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                   :: key_wd              !! The Key word we will look for
+  REAL(r_std), DIMENSION(:,:), INTENT(in)      :: val_put             !! 2D integer array to stored
+  LOGICAL,        OPTIONAL                        :: is_grid              !! Parameter present indicates a setvar for a grid variable 
+
+  REAL(r_std), ALLOCATABLE, DIMENSION(:,:)     :: val_tmp
+  INTEGER(i_std)                                     :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar_p) WRITE (numout,*) "r22setvar :", key_wd, val_exp, SIZE(val_put), val_put(1,1)
+
+  ALLOCATE(val_tmp(SIZE(val_put,DIM=1),SIZE(val_put,DIM=2)))
+  val_tmp(:,:) = val_put(:,:)
+
+  IF ( ALL( var(:,:) == val_exp ) ) THEN 
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:,:) = val_tmp(:,:)
+  END IF
+
+  DEALLOCATE(val_tmp)
+  
+END SUBROUTINE r22setvar_p
+
+!! Interface for initialising an 3D array real with a scalar real.
+SUBROUTINE r30setvar_p (var, val_exp, key_wd, val_put)
+
+  ! interface for scalar to 3D array real
+
+  REAL(r_std), DIMENSION(:,:,:), INTENT(inout) :: var                  !! 3D integer array to modify
+  REAL(r_std), INTENT(in)                      :: val_exp              !! Exceptional value
+  CHARACTER(LEN=*), INTENT(in)                :: key_wd               !! The Key word we will look for
+  REAL(r_std), INTENT(in)                      :: val_put              !! Scalar value to stored
+
+  REAL(r_std)                                  :: val_tmp 
+  INTEGER(i_std)                              :: is_key
+
+  is_key = MAX(INDEX(key_wd, 'NO_KEYWORD'), INDEX(key_wd, 'NOKEYWORD'))
+
+  IF (long_print_setvar_p) WRITE(numout,*) 'r30setvar',val_exp, val_put
+
+  val_tmp = val_put
+
+  IF ( ALL( var(:,:,:) == val_exp ) ) THEN
+     IF ( is_key <= 0 ) THEN
+       CALL getin_p(key_wd,  val_tmp)
+     ENDIF
+     var(:,:,:) = val_tmp
+  END IF
+
+END SUBROUTINE r30setvar_p
+
+END MODULE sechiba_io_p
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/slowproc.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/slowproc.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/slowproc.f90	(revision 55)
@@ -0,0 +1,4388 @@
+!
+! Daily update of leaf area index etc.
+!
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+!
+MODULE slowproc
+
+  ! modules used:
+
+  USE defprec
+  USE constantes 
+  USE constantes_veg
+  USE constantes_co2
+  USE ioipsl
+  USE sechiba_io
+  USE interpol_help
+  USE stomate
+  USE stomate_constants
+  USE grid
+  USE parallel
+!  USE Write_Field_p
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC slowproc_main,slowproc_clear
+
+  ! To use OLD or NEW iterpollation schemes :
+  INTERFACE slowproc_interlai
+     MODULE PROCEDURE slowproc_interlai_OLD, slowproc_interlai_NEW
+  END INTERFACE
+  INTERFACE slowproc_interpol
+     MODULE PROCEDURE slowproc_interpol_OLD, slowproc_interpol_NEW
+  END INTERFACE
+  INTERFACE slowproc_interpol_g
+     MODULE PROCEDURE slowproc_interpol_OLD_g, slowproc_interpol_NEW_g
+  END INTERFACE
+
+  !
+  ! variables used inside slowproc module : declaration and initialisation
+  !
+
+  LOGICAL, SAVE                                   :: l_first_slowproc = .TRUE.!! Initialisation has to be done one time
+  REAL(r_std), SAVE                                :: dt_slow                  !! time step of slow processes and STOMATE
+  !
+  REAL(r_std), SAVE                                :: clayfraction_default = 0.2
+
+  INTEGER(i_std) , SAVE                              :: veget_update=0   !! update frequency in years for landuse
+  INTEGER(i_std) , SAVE                              :: veget_year_orig=0     !! first year for landuse
+  LOGICAL, SAVE                                      :: land_use = .FALSE.        ! Land Use
+  LOGICAL, SAVE                                      :: veget_reinit=.FALSE.  !! To change LAND USE file in a run.
+  !
+  LOGICAL, SAVE                                   :: read_lai = .FALSE.        ! Lai Map
+  LOGICAL, SAVE                                   :: old_lai = .FALSE.         ! Old Lai Map interpolation
+  LOGICAL, SAVE                                   :: impveg = .FALSE.
+  LOGICAL, SAVE                                   :: impsoilt = .FALSE.
+  LOGICAL, SAVE                                   :: old_veget = .FALSE.         ! Old veget Map interpolation
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: clayfraction 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: laimap 
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: veget_nextyear          !! next year fraction of vegetation type
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)    :: frac_nobio_nextyear     !! next year fraction of ice+lakes+cities+...
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)      :: totfrac_nobio_nextyear  !! next year total fraction of ice+lakes+cities+...
+
+CONTAINS
+
+  SUBROUTINE slowproc_main (kjit, kjpij, kjpindex, dtradia, date0, &
+       ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
+       IndexLand, indexveg, lalo, neighbours, resolution, contfrac, soiltype, &
+       t2m, t2m_min, temp_sol, stempdiag, &
+       humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
+       deadleaf_cover, &
+       assim_param, &
+       lai, height, veget, frac_nobio, veget_max, totfrac_nobio, qsintmax, &
+       rest_id, hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+       co2_flux)
+
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                          :: kjit             !! Time step number
+    INTEGER(i_std), INTENT(in)                          :: kjpij            !! Total size of the un-compressed grid
+    INTEGER(i_std),INTENT (in)                          :: kjpindex         !! Domain size
+    REAL(r_std),INTENT (in)                             :: dtradia          !! Time step
+    REAL(r_std),INTENT (in)                             :: date0            !! Initial date
+    LOGICAL, INTENT(in)                                :: ldrestart_read   !! Logical for _restart_ file to read
+    LOGICAL, INTENT(in)                                :: ldrestart_write  !! Logical for _restart_ file to write
+    LOGICAL, INTENT(in)                                :: ldforcing_write  !! Logical for _forcing_ file to write
+    LOGICAL, INTENT(in)                                :: ldcarbon_write   !! Logical for _carbon_forcing_ file to write
+    INTEGER(i_std),INTENT (in)                          :: rest_id,hist_id  !! _Restart_ file and _history_ file identifier
+    INTEGER(i_std),INTENT (in)                          :: hist2_id         !! _history_ file 2 identifier
+    INTEGER(i_std),INTENT (in)                          :: rest_id_stom     !! STOMATE's _Restart_ file file identifier
+    INTEGER(i_std),INTENT (in)                          :: hist_id_stom     !! STOMATE's _history_ file file identifier
+    INTEGER(i_std),INTENT(in)                           :: hist_id_stom_IPCC !! STOMATE's IPCC _history_ file file identifier
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: IndexLand         !! Indeces of the points on the map
+    INTEGER(i_std),DIMENSION (kjpindex*nvm), INTENT (in) :: indexveg         !! Indeces of the points on the 3D map
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)     :: lalo             !! Geogr. coordinates (latitude,longitude) (degrees)
+    INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in)  :: neighbours       !! neighoring grid points if land
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)     :: resolution       !! size in x an y of the grid (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: contfrac         !! Fraction of continent in the grid
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT (in)  :: humrel           !! Relative humidity ("moisture stress")
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)        :: t2m              !! 2 m air temperature (K)
+    REAL(r_std), DIMENSION(kjpindex), INTENT(in)        :: t2m_min          !! min. 2 m air temp. during forcing time step (K)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: temp_sol         !! Surface temperature
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)  :: stempdiag        !! Soil temperature
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)  :: shumdiag         !! Relative soil moisture
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: litterhumdiag    !! Litter humidity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: precip_rain      !! Rain precipitation
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)       :: precip_snow      !! Snow precipitation
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)    :: gpp              !! GPP (gC/(m**2 of total ground)/time step)
+    ! output scalar 
+    ! output fields
+    REAL(r_std), DIMENSION (kjpindex,nvm), INTENT(out)      :: co2_flux         !! CO2 flux in gC/m**2 of average ground/second
+    ! modified scalar
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: lai              !! Surface foliaire
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: height           !! height (m)
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: veget            !! Fraction of vegetation type 
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (inout):: frac_nobio    !! Fraction of ice, lakes, cities etc. in the mesh
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: veget_max        !! Max fraction of vegetation type 
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)    :: totfrac_nobio    !! Total fraction of ice+lakes+cities etc. in the mesh
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(inout):: soiltype      !! fraction of soil type
+    REAL(r_std),DIMENSION (kjpindex,nvm,npco2), INTENT (inout):: assim_param!! min+max+opt temps, vcmax, vjmax for photosynthesis
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)    :: deadleaf_cover   !! fraction of soil covered by dead leaves
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (inout):: qsintmax         !! Maximum water on vegetation for interception
+
+    ! local declaration
+    INTEGER(i_std)                                     :: j, jv
+    INTEGER(i_std), SAVE                               :: lcanop           !! soil level used for LAI
+    REAL(r_std)                                         :: tmp_day(1)
+    CHARACTER(LEN=80)                                  :: var_name         !! To store variables names for I/O
+
+    !
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: resp_maint        !! autotrophic resp. (gC/(m**2 of total ground)/time step)
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: resp_hetero      !! heterotrophic resp. (gC/(m**2 of total ground)/time step)
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: resp_growth       !! growth resp. (gC/(m**2 of total ground)/time step)
+    REAL(r_std), DIMENSION(kjpindex,nvm)                :: npp               !! Net Ecosystem Exchange (gC/(m**2 of total ground)/time step)
+    !
+    INTEGER(i_std) , SAVE                               :: veget_year        !! year for landuse
+    LOGICAL                                             :: land_use_updated
+    !
+    LOGICAL, PARAMETER                                 :: check = .FALSE.
+
+    REAL(r_std), SAVE                                       :: sec_old = zero
+    !
+    ! do initialisation
+    !
+    IF (l_first_slowproc) THEN
+
+       !
+       ! 1.1 allocation, file definitions. Restart file read for Sechiba. Set flags.
+       !
+
+       IF (long_print) WRITE (numout,*) ' l_first_slowproc : call slowproc_init '
+       CALL slowproc_init (kjit, ldrestart_read, dtradia, date0, kjpindex, IndexLand, lalo, neighbours, resolution, contfrac, &
+            & rest_id, read_lai, lai, veget, frac_nobio, totfrac_nobio, soiltype, veget_max, height, lcanop,&
+            & veget_update, veget_year)
+       !
+       ! Time step in days for stomate
+       dt_days = dt_slow / one_day
+       !
+       resp_maint(:,:) = zero
+       resp_hetero(:,:) = zero
+       resp_growth(:,:) = zero
+       !
+       ! 1.2 check time step
+       !
+       IF ( dt_slow .LT. dtradia ) THEN
+          WRITE(numout,*) 'slow_processes: time step smaller than forcing time step.'
+          STOP 'slowproc_main'
+       ENDIF
+       !
+       IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
+          !
+          ! 1.3 call STOMATE for initialization
+          !
+          CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
+               ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
+               IndexLand, lalo, neighbours, resolution, contfrac, totfrac_nobio, clayfraction, &
+               t2m, t2m_min, temp_sol, stempdiag, &
+               humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
+               deadleaf_cover, &
+               assim_param, &
+               lai, height, veget, veget_max, qsintmax, &
+               veget_nextyear, totfrac_nobio_nextyear, &
+               hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+               co2_flux,resp_maint,resp_hetero,resp_growth)
+          !
+       ENDIF
+       !
+       IF ( .NOT. control%ok_stomate ) THEN
+          !
+          ! 1.4 initialize some variables
+          !     STOMATE diagnoses some variables for SECHIBA: height, deadleaf_cover, etc.
+          !     IF SECHIBA is not coupled to STOMATE, then we must set these values otherwise.
+          !
+          CALL slowproc_derivvar (kjpindex, veget, lai, &
+               qsintmax, deadleaf_cover, assim_param, height)
+       ENDIF
+
+       RETURN
+
+    ENDIF
+    !
+!!$    ! Land USE for next year
+!!$    land_use_updated=.FALSE.
+!!$    IF ( (land_use) .AND. (veget_update .GT. 0) ) THEN
+!!$       ! if next iteration is divisibled by veget_update
+!!$       IF ( mod(kjit+1, veget_update) .le. min_sechiba) THEN
+!!$          !
+!!$          veget_year=veget_year+veget_year_add
+!!$          WRITE(numout,*)  'We are updating veget for year =' , veget_year
+!!$          !
+!!$          ! Save veget
+!!$          !
+!!$          veget_lastyear(:,:) = veget_max(:,:)
+!!$          !
+!!$          CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
+!!$               &               veget_max, frac_nobio, veget_year)                
+!!$
+!!$          land_use_updated=.TRUE.
+!!$       ENDIF
+!!$    ENDIF
+    !
+    ! prepares restart file for the next simulation
+    !
+    IF (ldrestart_write) THEN
+
+       IF (long_print) WRITE (numout,*) ' we have to complete restart file with SLOWPROC variables '
+
+       tmp_day(1) = day_counter
+       var_name= 'day_counter'
+       IF (is_root_prc) CALL restput (rest_id, var_name, 1 , 1  , 1, kjit, tmp_day)
+
+       var_name= 'veget'
+       CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, veget, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'veget_max'
+       CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, veget_max, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'lai'
+       CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, lai, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'frac_nobio'
+       CALL restput_p (rest_id, var_name, nbp_glo, nnobio, 1, kjit, frac_nobio, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'soiltype_frac'
+       CALL restput_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, soiltype, 'scatter',  nbp_glo, index_g)
+       !
+       var_name= 'clay_frac'
+       CALL restput_p (rest_id, var_name, nbp_glo, 1, 1, kjit, clayfraction, 'scatter',  nbp_glo, index_g)
+       !
+       ! The height of the vegetation could in principle be recalculated at the beginning of the run.
+       ! However, this is very tedious, as many special cases have to be taken into account. This variable
+       ! is therefore saved in the restart file.
+       var_name= 'height'
+       CALL restput_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, height, 'scatter',  nbp_glo, index_g)
+       !
+       IF (read_lai) THEN     
+          var_name= 'laimap'
+          CALL restput_p (rest_id, var_name, nbp_glo, nvm, 12, kjit, laimap)
+       ENDIF
+       !
+       IF (land_use) THEN
+          tmp_day(1) = REAL(veget_year,r_std)
+          var_name='veget_year'
+          IF (is_root_prc) CALL restput (rest_id, var_name, 1 , 1  , 1, kjit, tmp_day)
+       ENDIF
+       !
+       ! call STOMATE to write RESTART files
+       !
+       IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
+          CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
+               ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
+               IndexLand, lalo, neighbours, resolution, contfrac, totfrac_nobio, clayfraction, &
+               t2m, t2m_min, temp_sol, stempdiag, &
+               humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
+               deadleaf_cover, &
+               assim_param, &
+               lai, height, veget, veget_max, qsintmax, &
+               veget_nextyear, totfrac_nobio_nextyear, &
+               hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+               co2_flux,resp_maint,resp_hetero,resp_growth)
+       ENDIF
+
+       RETURN
+
+    END IF
+    !
+    ! update day counter
+    day_counter = day_counter + dtradia
+
+    IF (check) WRITE(*,*) "slowproc: day_counter 3",day_counter
+    !
+    !
+    ! 1. Compute date
+    !
+    ! Test each day and assert all slow processes (days and years)
+    !
+    IF ( sec_old >= one_day - dtradia .AND.  sec >= zero ) THEN
+       !
+       ! reset counter
+       day_counter = zero
+       IF (check) WRITE(*,*) "slowproc: day_counter 2",day_counter
+       !
+       ! Active slow processes
+       do_slow = .TRUE.
+       !
+       ! count days 
+       date = date + nint(dt_days)
+       IF (check) WRITE(numout,*) "New date : ",date, 'year_length ',year_length,kjit
+       !
+       ! is one year over?
+       !     EndOfYear must be true once per year
+       !     during a call of stomate_season.
+       !
+       IF ( month == 1 .AND. day == 1 .AND. sec .LT. dtradia ) THEN
+          EndOfYear = .TRUE.
+       ELSE
+          EndOfYear = .FALSE.
+       ENDIF
+       
+    ELSE
+       do_slow = .FALSE.
+       EndOfYear = .FALSE.
+    ENDIF
+    sec_old = sec
+
+    IF ( EndOfYear ) THEN
+       WRITE(numout,*)  'slowproc: EndOfYear is activated.'
+    ENDIF
+
+    ! Land USE for next year
+    land_use_updated=.FALSE.
+    IF ( (land_use) .AND. (veget_update .GT. 0) ) THEN
+       ! if next iteration is divisibled by veget_update
+       IF ( EndOfYear ) THEN
+          !
+          veget_year = veget_year + 1
+          !
+          IF ( MOD(veget_year - veget_year_orig, veget_update) == 0 ) THEN
+          
+             WRITE(numout,*)  'We are updating land use veget for year =' , veget_year
+             !
+             CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
+               &               veget_max, frac_nobio, veget_nextyear, frac_nobio_nextyear, veget_year)
+             !
+             ! If some PFT has disapeared in new map
+             WHERE(veget_nextyear(:,:).LT.veget(:,:))
+                veget(:,:) = veget_nextyear(:,:)
+             ENDWHERE
+             !
+             DO j = 1, nnobio
+                totfrac_nobio_nextyear(:) = totfrac_nobio_nextyear(:) + frac_nobio_nextyear(:,j)
+             ENDDO
+             land_use_updated=.TRUE.
+             !
+          ENDIF
+          !
+       ENDIF
+    ENDIF ! Land Use part
+    IF (EndOfYear .AND. .NOT. land_use_updated) THEN
+       lcchange=.FALSE.
+    ENDIF
+
+    IF ( control%stomate_watchout .OR. control%ok_stomate ) THEN
+       !
+       ! 2. call STOMATE, either because we want to keep track of long-term variables or
+       !   because STOMATE is activated
+       !
+       CALL stomate_main (kjit, kjpij, kjpindex, dtradia, dt_slow, &
+            ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
+            IndexLand, lalo, neighbours, resolution, contfrac, totfrac_nobio, clayfraction, &
+            t2m, t2m_min, temp_sol, stempdiag, &
+            humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, gpp, &
+            deadleaf_cover, &
+            assim_param, &
+            lai, height, veget, veget_max, qsintmax, &
+            veget_nextyear, totfrac_nobio_nextyear, &
+            hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+            co2_flux,resp_maint,resp_hetero,resp_growth)
+       IF ( control%ok_stomate .AND. control%ok_sechiba ) THEN
+          CALL histwrite(hist_id, 'maint_resp', kjit, resp_maint, kjpindex*nvm, indexveg)
+          CALL histwrite(hist_id, 'hetero_resp', kjit, resp_hetero, kjpindex*nvm, indexveg)
+          CALL histwrite(hist_id, 'growth_resp', kjit, resp_growth, kjpindex*nvm, indexveg)
+          npp(:,1)=zero
+          DO j = 2,nvm
+             npp(:,j) = gpp(:,j) - resp_growth(:,j) - resp_maint(:,j)
+          ENDDO
+          CALL histwrite(hist_id, 'npp', kjit, npp, kjpindex*nvm, indexveg)
+       ENDIF
+       IF ( hist2_id > 0 ) THEN
+          IF ( control%ok_stomate ) THEN
+             CALL histwrite(hist2_id, 'maint_resp', kjit, resp_maint, kjpindex*nvm, indexveg)
+             CALL histwrite(hist2_id, 'hetero_resp', kjit, resp_hetero, kjpindex*nvm, indexveg)
+             CALL histwrite(hist2_id, 'growth_resp', kjit, resp_growth, kjpindex*nvm, indexveg)
+             CALL histwrite(hist2_id, 'npp', kjit, npp, kjpindex*nvm, indexveg)
+          ENDIF
+       ENDIF
+    ENDIF
+    !
+    IF ( .NOT. control%ok_stomate ) THEN
+
+       !
+       ! 2 STOMATE is not activated: we have to guess lai etc.
+       !
+
+       !
+       ! 2.2 test if we have work to do
+       !
+
+       IF ( do_slow .OR. land_use_updated ) THEN
+          !
+          ! 2.2.1 do daily processes if necessary
+          !
+          IF (long_print) WRITE (numout,*) 'slowproc_main : We update the daily variables'
+
+          ! 2.2.2 updates lai
+          CALL slowproc_lai (kjpindex, lcanop,stempdiag, &
+               lalo,resolution,lai,month,day,read_lai,laimap)
+          !
+          IF (land_use_updated) THEN
+             veget_max(:,:)=veget_nextyear(:,:)
+             frac_nobio(:,:)=frac_nobio_nextyear(:,:)
+          ENDIF
+          !
+          ! 2.2.3 updates veget
+          CALL slowproc_veget (kjpindex, lai, frac_nobio, veget_max, veget)
+          totfrac_nobio(:) = zero
+          DO jv = 1, nnobio
+             totfrac_nobio(:) = totfrac_nobio(:) + frac_nobio(:,jv)
+          ENDDO
+
+          ! 2.2.4 updates qsintmax and other derived variables
+          CALL slowproc_derivvar (kjpindex, veget, lai, &
+               qsintmax, deadleaf_cover, assim_param, height)
+       ELSE
+          !
+          IF (land_use_updated) THEN
+             frac_nobio(:,:)=frac_nobio_nextyear(:,:)
+          ENDIF
+          !
+       END IF
+
+       !
+       ! 2.3 some output fields
+       !
+
+       co2_flux(:,:) = zero
+
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' slowproc_main done '
+
+  END SUBROUTINE slowproc_main
+!!
+!!
+!!
+  SUBROUTINE slowproc_init (kjit, ldrestart_read, dtradia, date0, kjpindex, IndexLand, lalo, neighbours, resolution, contfrac, &
+       & rest_id, read_lai, lai, veget, frac_nobio, totfrac_nobio, soiltype, veget_max, height, lcanop,&
+       & veget_update, veget_year)
+
+    ! interface description
+    ! input scalar
+    INTEGER(i_std), INTENT (in)                          :: kjit           !! Time step number
+    LOGICAL, INTENT (in)                                 :: ldrestart_read !! Logical for _restart_ file to read
+    REAL(r_std),INTENT (in)                               :: dtradia        !! Time step
+    REAL(r_std), INTENT (in)                              :: date0          !! intial date
+    INTEGER(i_std), INTENT (in)                          :: kjpindex       !! Domain size
+    INTEGER(i_std), INTENT (in)                          :: rest_id        !! _Restart_ file identifier
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)     :: IndexLand          !! Indeces of the points on the map
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)       :: lalo           !! Geogr. coordinates (latitude,longitude) (degrees)
+    INTEGER(i_std), DIMENSION (kjpindex,8), INTENT(in)   :: neighbours     !! neighoring grid points if land
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)       :: resolution     !! size in x an y of the grid (m)
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)         :: contfrac       !! Fraction of continent in the grid
+    ! output scalar
+    INTEGER(i_std), INTENT(out)                          :: lcanop         !! soil level used for LAI
+    INTEGER(i_std), INTENT(out)                          :: veget_update   !! update frequency in timesteps for landuse
+    INTEGER(i_std), INTENT(out)                          :: veget_year     !! first year for landuse
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: lai            !! Surface foliere
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: veget          !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex,nnobio), INTENT (out) :: frac_nobio     !! Fraction of ice,lakes,cities, ...
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)        :: totfrac_nobio  !! Total fraction of ice+lakes+cities+...
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: veget_max      !! Max fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)    :: height         !! Height of vegetation
+    REAL(r_std), DIMENSION (kjpindex,nstm), INTENT(out)   :: soiltype       !! fraction of soil type
+    ! local declaration
+    REAL(r_std)                                           :: tmp_day(1)
+    REAL(r_std)                                           :: tmp_veget_year(1)
+    REAL(r_std)                                           :: zcanop         !! soil depth taken for canopy
+    INTEGER(i_std)                                       :: vtmp(1)
+    REAL(r_std), DIMENSION(nbdl)                          :: zsoil          !! soil depths at diagnostic levels
+    INTEGER(i_std)                                       :: j,l            !! Index
+    CHARACTER(LEN=80)                                    :: var_name       !! To store variables names for I/O
+    INTEGER(i_std)                                       :: ji, jv, ier
+    LOGICAL, INTENT(out)                                 ::  read_lai
+    REAL(r_std)                                           :: frac_nobio1    !! temporary
+    REAL(r_std)                                           :: stempdiag_bid  !! only needed for an initial LAI 
+                                                                            !! if there is no restart file
+    REAL(r_std), DIMENSION(kjpindex,nbdl)                 :: stempdiag2_bid !! matrix to store stempdiag_bid
+    CHARACTER(LEN=4)                                     :: vegsoil_dist   !! Flag to choose the soil/vegetation distribution
+    !
+    CHARACTER(LEN=30), SAVE                              :: veget_str        !! update frequency for landuse
+    REAL(r_std),DIMENSION (nbp_glo,nnobio)               :: frac_nobio_g    !! Fraction of ice, lakes, cities etc. in the mesh (global)
+    REAL(r_std),DIMENSION (nbp_glo,nvm)                  :: veget_max_g     !! Fraction of vegetation type (globa)
+
+    LOGICAL, PARAMETER                                 :: check = .FALSE.
+    !
+    ! 1 allocation
+    !
+
+    ALLOCATE (clayfraction(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+       WRITE (numout,*) ' error in clayfraction allocation. We stop. We need kjpindex words = ',kjpindex
+       STOP 'slowproc_init'
+    END IF
+    clayfraction(:)=undef_sechiba
+    !
+    veget_max(:,1) = un
+    veget_max(:,2:nvm) = zero
+    frac_nobio(:,:) = zero
+    totfrac_nobio(:) = zero
+    !
+    ier=-1
+    ALLOCATE(veget_nextyear(kjpindex, nvm), STAT=ier)
+    IF (ier/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of veget_nextyear : ",ier
+      STOP 
+    ENDIF
+    veget_nextyear(:,1) = un
+    veget_nextyear(:,2:nvm) = zero
+    !
+    ier=-1
+    ALLOCATE(frac_nobio_nextyear(kjpindex, nnobio), STAT=ier)
+    IF (ier/=0) THEN
+      PRINT *,"ERROR IN ALLOCATION of frac_nobio_nextyear : ",ier
+      STOP 
+    ENDIF
+    frac_nobio_nextyear(:,:) = zero
+    !
+    ier=-1
+    ALLOCATE(totfrac_nobio_nextyear(kjpindex), STAT=ier)
+    IF (ier/=0) THEN
+      PRINT *,"ERROR IN ALLOCATION of totfrac_nobio_nextyear : ",ier
+      STOP 
+    ENDIF
+!MM must be corrected when nnobio > 1 !!
+    totfrac_nobio_nextyear(:) = nnobio*un
+    !
+    ! 2 read restart file
+    !
+
+    var_name= 'day_counter'
+    CALL ioconf_setatt('UNITS', 'd')
+    CALL ioconf_setatt('LONG_NAME','Fraction of computed day')
+    IF (is_root_prc) THEN
+       CALL restget (rest_id, var_name, 1       , 1  , 1, kjit, .TRUE., tmp_day)
+       IF (tmp_day(1) == val_exp) THEN
+          day_counter = zero
+       ELSE
+          day_counter = tmp_day(1)
+       ENDIF
+    ENDIF
+    CALL bcast(day_counter)
+
+    ! get restart value if none were found in the restart file
+    !
+    !Config Key  = SECHIBA_DAY
+    !Config Desc = Time within the day simulated
+    !Config Def  = 0.0
+    !Config Help = This is the time spent simulating the current day. This variable is
+    !Config        prognostic as it will trigger all the computations which are
+    !Config        only done once a day.
+    !
+    CALL setvar_p (day_counter, val_exp, 'SECHIBA_DAY', zero)
+    !
+    !Config Key  = LAI_MAP
+    !Config Desc = Read the LAI map
+    !Config Def  = n
+    !Config Help = It is possible to read a 12 month LAI map which will
+    !Config        then be interpolated to daily values as needed.
+    !
+    read_lai = .FALSE.
+    CALL getin_p('LAI_MAP',read_lai)
+    !
+    var_name= 'veget'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Vegetation fraction')
+    CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., veget, "gather", nbp_glo, index_g)
+    !
+    var_name= 'veget_max'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Maximum vegetation fraction')
+    CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., veget_max, "gather", nbp_glo, index_g)
+   
+    !
+    frac_nobio(:,:) = val_exp
+    var_name= 'frac_nobio'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Special soil type fraction')
+    CALL restget_p (rest_id, var_name, nbp_glo, nnobio, 1, kjit, .TRUE., frac_nobio, "gather", nbp_glo, index_g)
+    !
+    !Config Key  = LAND_USE
+    !Config Desc = Read a land_use vegetation map
+    !Config Def  = n
+    !Config Help = pft values are needed, max time axis is 293
+    !
+    land_use = .FALSE.
+    veget_update=0
+    CALL getin_p('LAND_USE',land_use)
+    IF (land_use) THEN
+       !
+       !Config Key  = VEGET_YEAR
+       !Config Desc = Year of the land_use vegetation map to be read (0 == NO TIME AXIS)
+       !Config If   = LAND_USE
+       !Config Def  = 282
+       !Config Help = First year for landuse vegetation (2D map by pft).
+       !Config Help   If VEGET_YEAR == 0, this means there is no time axis.
+       !
+       veget_year_orig=282
+       CALL getin_p('VEGET_YEAR', veget_year_orig)
+       !
+       !Config Key  = VEGET_REINIT
+       !Config Desc = booleen to indicate that a new LAND USE file will be used.
+       !Config If   = LAND_USE
+       !Config Def  = n
+       !Config Help = The parameter is used to bypass veget_year count 
+       !Config Help   and reinitialize it with VEGET_YEAR parameter.
+       !Config Help   Then it is possible to change LAND USE file.
+       !
+       veget_reinit = .FALSE.
+       CALL getin_p('VEGET_REINIT', veget_reinit)
+       !
+       !
+       var_name= 'veget_year'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Last year get in Land Use file.')
+       IF (is_root_prc) THEN
+          CALL restget (rest_id, var_name, 1       , 1  , 1, kjit, .TRUE., tmp_veget_year)
+          !
+          IF (tmp_veget_year(1) == val_exp) THEN
+             veget_year=veget_year_orig
+          ELSE
+             IF (veget_reinit) THEN
+                veget_year=veget_year_orig
+             ELSE
+                veget_year=INT(tmp_veget_year(1))
+             ENDIF
+          ENDIF
+       ENDIF
+       CALL bcast(veget_year)
+       !
+       !Config Key  = VEGET_UPDATE
+       !Config Desc = Update vegetation frequency
+       !Config If   = LAND_USE
+       !Config Def  = 0Y
+       !Config Help = The veget datas will be update each this time step.
+       !
+       veget_update=0
+       WRITE(veget_str,'(a)') '0Y'
+       CALL getin_p('VEGET_UPDATE', veget_str)
+       !
+       !
+       l=INDEX(TRIM(veget_str),'Y')
+       READ(veget_str(1:(l-1)),"(I2.2)") veget_update
+       WRITE(numout,*) "Update frequency for land use in years :",veget_update
+       !
+       !Config  Key  = LAND_COVER_CHANGE
+       !Config  Desc = treat land use modifications
+       !Config  If   = LAND_USE
+       !Config  Def  = y
+       !Config  Help = With this variable, you can use a Land Use map
+       !Config         to simulate anthropic modifications such as 
+       !Config         deforestation.
+       !
+       lcchange = .TRUE.  
+       CALL getin_p('LAND_COVER_CHANGE', lcchange)
+       IF ( veget_update == 0 .AND. lcchange ) THEN
+          CALL ipslerr (2,'slowproc_init', &
+             &     'You have asked for LAND_COVER_CHANGE activated with VEGET_UPDATE = 0Y.',&
+             &     'We can''t use this land cover change model if veget is not updated.', &
+             &     'We have disabled it.')
+          lcchange=.FALSE.
+       ENDIF
+
+    ENDIF
+    !
+    var_name= 'soiltype_frac'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Fraction of each soil type')
+    CALL restget_p (rest_id, var_name, nbp_glo, nstm, 1, kjit, .TRUE., soiltype, "gather", nbp_glo, index_g)
+    !
+    var_name= 'clay_frac'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Fraction of clay in each mesh')
+    CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., clayfraction, "gather", nbp_glo, index_g)
+    !
+    var_name= 'lai'
+    CALL ioconf_setatt('UNITS', '-')
+    CALL ioconf_setatt('LONG_NAME','Leaf area index')
+    CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., lai, "gather", nbp_glo, index_g)
+    !
+    ! The height of the vegetation could in principle be recalculated at the beginning of the run.
+    ! However, this is very tedious, as many special cases have to be taken into account. This variable
+    ! is therefore saved in the restart file.
+    var_name= 'height'
+    CALL ioconf_setatt('UNITS', 'm')
+    CALL ioconf_setatt('LONG_NAME','Height of vegetation')
+    CALL restget_p (rest_id, var_name, nbp_glo, nvm, 1, kjit, .TRUE., height, "gather", nbp_glo, index_g)
+    
+    !
+    IF (read_lai)THEN
+       !
+       ALLOCATE (laimap(kjpindex,nvm,12),stat=ier)
+       IF (ier.NE.0) THEN
+          WRITE (numout,*) ' error in laimap allocation. We stop. We need kjpindex*nvm*12 words = ',kjpindex*nvm*12
+          STOP 'slowproc_init'
+       END IF
+       laimap(:,:,:) = val_exp
+       !
+       var_name= 'laimap'
+       CALL ioconf_setatt('UNITS', '-')
+       CALL ioconf_setatt('LONG_NAME','Leaf area index read')
+       CALL restget_p (rest_id, var_name, nbp_glo, nvm, 12, kjit, .TRUE., laimap)
+       !
+    ELSE
+       !
+       ALLOCATE (laimap(1,1,1))
+    ENDIF
+    !
+    !Config Key  = SECHIBA_ZCANOP
+    !Config Desc = Soil level (m) used for canopy development (if STOMATE disactivated)
+    !Config Def  = 0.5
+    !Config Help = The temperature at this soil depth is used to determine the LAI when
+    !Config        STOMATE is not activated.
+    !
+    zcanop = 0.5_r_std
+    CALL setvar_p (zcanop, val_exp, 'SECHIBA_ZCANOP', 0.5_r_std)
+    !
+    !Config Key  = HYDROL_SOIL_DEPTH
+    !Config Desc = Total depth of soil reservoir
+    !Config Def  = 2.
+    !
+    dpu_cste=2.
+    CALL getin_p ("HYDROL_SOIL_DEPTH", dpu_cste)
+    dpu(:)=dpu_cste
+    !
+    !Config Key  = HYDROL_HUMCSTE
+    !Config Desc = Root profile
+    !Config Def  = 5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4.
+    !Config Help = Default values were defined for 2 meters soil depth.
+    !Config        For 4 meters soil depth, you may use those ones :
+    !Config        5., .4, .4, 1., .8, .8, 1., 1., .8, 4., 1., 4., 1.
+    !
+    humcste(:)= &
+         & (/5., .8, .8, 1., .8, .8, 1., 1., .8, 4., 4., 4., 4./)
+    CALL getin_p ("HYDROL_HUMCSTE", humcste)
+
+!MM, T. d'O. : before in constantes_soil :
+!          diaglev = &
+!               & (/ 0.001, 0.004, 0.01,  0.018, 0.045, &
+!               &    0.092, 0.187, 0.375, 0.750, 1.5,   &
+!               &    2.0 /)
+       ! Place here because it is used in sechiba and stomate (then in teststomate)
+       ! to be in sechiba when teststomate will have disapeared.
+!MM Problem here with dpu which depends on soil type
+    DO jv = 1, nbdl-1
+       ! first 2.0 is dpu 
+       ! second 2.0 is average
+       diaglev(jv) = dpu_cste/(2**(nbdl-1) -1) * ( ( 2**(jv-1) -1) + ( 2**(jv) -1) ) / 2.0
+    ENDDO
+    diaglev(nbdl) = dpu_cste
+
+    ! depth at center of the levels
+    zsoil(1) = diaglev(1) / 2.
+    DO l = 2, nbdl
+       zsoil(l) = ( diaglev(l) + diaglev(l-1) ) / 2.
+    ENDDO
+
+    ! index of this level
+    vtmp = MINLOC ( ABS ( zcanop - zsoil(:) ) )
+    lcanop = vtmp(1)
+
+    !
+    !  Interception reservoir coefficient
+    !
+    !Config  Key  = 'SECHIBA_QSINT' 
+    !Config  Desc = Interception reservoir coefficient
+    !Config  Def  = 0.1
+    !Config  Help = Transforms leaf area index into size of interception reservoir
+    !Config         for slowproc_derivvar or stomate
+
+    qsintcst = 0.1
+    CALL getin_p('SECHIBA_QSINT', qsintcst)
+    WRITE(numout, *)' SECHIBA_QSINT, qsintcst = ', qsintcst
+
+    !
+    ! Time step of STOMATE and LAI update
+    !
+    !Config  Key  = DT_SLOW
+    !Config  Desc = Time step of STOMATE and other slow processes
+    !Config  Def  = one_day
+    !Config  Help = Time step (s) of regular update of vegetation
+    !Config         cover, LAI etc. This is also the time step
+    !Config         of STOMATE.
+
+    dt_slow = one_day
+    CALL getin_p('DT_SLOW', dt_slow)
+    !
+
+    !Config Key  = SLOWPROC_LAI_TEMPDIAG
+    !Config Desc = Temperature used for the initial guess of LAI
+    !Config Def  = 280.
+    !Config Help = If there is no LAI in the restart file, we may need
+    !Config        a temperature that is used to guess the initial LAI.
+    !
+    stempdiag_bid = 280.
+    CALL getin_p('SLOWPROC_LAI_TEMPDIAG',stempdiag_bid)
+    ! 
+    !
+    ! get restart value if none were found in the restart file
+    !
+    !Config  Key  = AGRICULTURE
+    !Config  Desc = agriculture allowed?
+    !Config  Def  = y
+    !Config  Help = With this variable, you can determine
+    !Config         whether agriculture is allowed
+    !
+    agriculture = .TRUE.
+    CALL getin_p('AGRICULTURE', agriculture)
+    IF ( .NOT. agriculture .AND. land_use ) THEN 
+       CALL ipslerr (2,'slowproc_init', &
+               &     'Problem with agriculture desactivated and Land Use activated.',&
+               &     'Are you sure ?', &
+               &     '(check your parameters).')
+    ENDIF
+
+    !
+    !Config Key  = IMPOSE_VEG
+    !Config Desc = Should the vegetation be prescribed
+    !Config Def  = n
+    !Config Help = This flag allows the user to impose a vegetation distribution
+    !Config        and its characterisitcs. It is espacially interesting for 0D
+    !Config        simulations. On the globe it does not make too much sense as
+    !Config        it imposes the same vegetation everywhere
+    !
+    impveg = .FALSE.
+    CALL getin_p('IMPOSE_VEG', impveg)
+    !
+    IF ( impveg ) THEN
+       !
+       !  We are on a point and thus we can read the information from the run.def
+       !
+       !Config Key  = SECHIBA_VEG
+       !Config Desc = Vegetation distribution within the mesh (0-dim mode)
+       !Config If   = IMPOSE_VEG
+       !Config Def  = 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0
+       !Config Help = The fraction of vegetation is read from the restart file. If
+       !Config        it is not found there we will use the values provided here.
+       !
+       CALL setvar_p (veget, val_exp, 'SECHIBA_VEG', veget_ori_fixed_test_1)
+
+       !
+       !Config Key  = SECHIBA_VEGMAX
+       !Config Desc = Maximum vegetation distribution within the mesh (0-dim mode)
+       !Config If   = IMPOSE_VEG
+       !Config Def  = 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.8, 0.0, 0.0, 0.0
+       !Config Help = The fraction of vegetation is read from the restart file. If
+       !Config        it is not found there we will use the values provided here.
+       !
+       CALL setvar_p (veget_max, val_exp, 'SECHIBA_VEGMAX', veget_ori_fixed_test_1)
+
+       !
+       !Config Key  = SECHIBA_FRAC_NOBIO
+       !Config Desc = Fraction of other surface types within the mesh (0-dim mode)
+       !Config If   = IMPOSE_VEG
+       !Config Def  = 0.0
+       !Config Help = The fraction of ice, lakes, etc. is read from the restart file. If
+       !Config        it is not found there we will use the values provided here.
+       !Config        For the moment, there is only ice.
+       !
+       ! laisser ca tant qu'il n'y a que la glace. Pb avec setvar?
+       frac_nobio1 = frac_nobio(1,1)
+       CALL setvar_p (frac_nobio1, val_exp, 'SECHIBA_FRAC_NOBIO', frac_nobio_fixed_test_1)
+       frac_nobio(:,:) = frac_nobio1
+       ! CALL setvar (frac_nobio, val_exp, 'SECHIBA_FRAC_NOBIO', frac_nobio_fixed_test_1)
+
+       !
+       !Config Key  = SECHIBA_LAI
+       !Config Desc = LAI for all vegetation types (0-dim mode)
+       !Config Def  = 0., 8., 8., 4., 4.5, 4.5, 4., 4.5, 4., 2., 2., 2., 2.
+       !Config If   = IMPOSE_VEG
+       !Config Help = The maximum LAI used in the 0dim mode. The values should be found
+       !Config        in the restart file. The new values of LAI will be computed anyway
+       !Config        at the end of the current day. The need for this variable is caused
+       !Config        by the fact that the model may stop during a day and thus we have not
+       !Config        yet been through the routines which compute the new surface conditions.
+       !
+       CALL setvar_p (lai, val_exp, 'SECHIBA_LAI', llaimax)
+
+       !
+       !Config Key  = IMPOSE_SOILT
+       !Config Desc = Should the soil typ be prescribed
+       !Config Def  = n
+       !Config If   = IMPOSE_VEG
+       !Config Help = This flag allows the user to impose a soil type distribution.
+       !Config        It is espacially interesting for 0D
+       !Config        simulations. On the globe it does not make too much sense as
+       !Config        it imposes the same soil everywhere
+       !
+       impsoilt = .FALSE.
+       CALL getin_p('IMPOSE_SOILT', impsoilt)
+       IF (impsoilt) THEN
+          !Config Key  = SOIL_FRACTIONS
+          !Config Desc = Fraction of the 3 soil types (0-dim mode)
+          !Config Def  = 0.28, 0.52, 0.20
+          !Config If   = IMPOSE_VEG
+          !Config If   = IMPOSE_SOILT
+          !Config Help = Determines the fraction for the 3 soil types
+          !Config        in the mesh in the following order : sand loam and clay.
+          !
+          CALL setvar_p (soiltype, val_exp, 'SOIL_FRACTIONS', soiltype_default)
+
+          !Config Key  = CLAY_FRACTION
+          !Config Desc = Fraction of the clay fraction (0-dim mode)
+          !Config Def  = 0.2
+          !Config If   = IMPOSE_VEG
+          !Config If   = IMPOSE_SOILT
+          !Config Help = Determines the fraction of clay in the grid box.
+          !
+          CALL setvar_p (clayfraction, val_exp, 'CLAY_FRACTION', clayfraction_default)
+       ELSE
+          IF ( MINVAL(soiltype) .EQ. MAXVAL(soiltype) .AND. MAXVAL(soiltype) .EQ. val_exp .OR.&
+               & MINVAL(clayfraction) .EQ. MAXVAL(clayfraction) .AND. MAXVAL(clayfraction) .EQ. val_exp) THEN
+
+             CALL slowproc_soilt(kjpindex, lalo, neighbours, resolution, contfrac, soiltype, clayfraction)
+          ENDIF
+       ENDIF
+       !
+       !Config Key  = SLOWPROC_HEIGHT
+       !Config Desc = Height for all vegetation types (m)
+       !Config Def  = 0., 30., 30., 20., 20., 20., 15., 15., 15., .5, .6, 1.0, 1.0
+       !Config If   = IMPOSE_VEG
+       !Config Help = The height used in the 0dim mode. The values should be found
+       !Config        in the restart file. The new values of height will be computed anyway
+       !Config        at the end of the current day. The need for this variable is caused
+       !Config        by the fact that the model may stop during a day and thus we have not
+       !Config        yet been through the routines which compute the new surface conditions.
+       !
+       CALL setvar_p (height, val_exp, 'SLOWPROC_HEIGHT', height_presc)
+
+    ELSE
+       !
+       !  We are in the full 2-D case thus we need to do the interpolation if the potential vegetation
+       !  is not available
+       !
+       IF ( ALL( veget_max(:,:) .EQ. val_exp ) .OR. ALL( frac_nobio(:,:) .EQ. val_exp ) ) THEN
+
+          IF ( .NOT. land_use ) THEN
+
+             !Config Key  = SLOWPROC_VEGET_OLD_INTERPOL
+             !Config Desc = Flag to use old "interpolation" of vegetation map.
+             !Config If   = NOT IMPOSE_VEG and NOT LAND_USE
+             !Config Def  = FALSE
+             !Config Help = If you want to recover the old (ie orchidee_1_2 branch) 
+             !Config        "interpolation" of vegetation map.
+             !
+             old_veget = .FALSE.
+             CALL getin_p('SLOWPROC_VEGET_OLD_INTERPOL',old_veget)
+
+             ! The interpolation of vegetation has changed.
+             IF (is_root_prc) THEN
+                IF ( .NOT. old_veget ) THEN
+                   ! NEW slowproc interpol :
+                   CALL slowproc_interpol_g(nbp_glo, lalo_g, neighbours_g, resolution_g, contfrac_g, veget_max_g, frac_nobio_g)
+                ELSE
+                   ! OLD slowproc interpol :
+                   CALL slowproc_interpol_g(nbp_glo, lalo_g, neighbours_g, resolution_g, veget_max_g, frac_nobio_g)
+                ENDIF
+             ENDIF
+             CALL scatter(veget_max_g,veget_max)
+             CALL scatter(frac_nobio_g, frac_nobio)
+             !
+             IF ( control%ok_dgvm ) THEN
+                !
+                ! If we are dealing with dynamic vegetation then all
+                ! natural PFTs should be set to veget_max = 0
+                !  And in case no agriculture is desired, agriculture PFTS should be
+                ! set to 0 as well
+             
+                IF (agriculture) THEN
+                   veget_max(:,2:nvm-2) = zero
+                   DO ji = 1, kjpindex
+                      veget_max(ji,1) = un - SUM(veget_max(ji,nvm-1:nvm)) &
+                           - SUM(frac_nobio(ji,:))
+                   ENDDO
+                ELSE
+                   veget_max(:,:) = zero
+                   DO ji = 1, kjpindex
+                      veget_max(ji,1) = un  - SUM(frac_nobio(ji,:))
+                   ENDDO
+                ENDIF
+                !
+             ENDIF
+          ELSE
+             WRITE(numout,*)  'We initialize land use veget for year =' , veget_year
+             ! If restart doesn''t contain veget, then it is the first computation
+             CALL slowproc_update(kjpindex, lalo, neighbours, resolution, contfrac, &
+               &               veget_nextyear, frac_nobio_nextyear, veget_max, frac_nobio, veget_year, init=.TRUE.)
+             !
+             IF ( control%ok_dgvm  ) THEN
+                !
+                ! If we are dealing with dynamic vegetation then all
+                ! natural PFTs should be set to veget_max = 0
+                !  And in case no agriculture is desired, agriculture PFTS should be
+                ! set to 0 as well
+                
+                IF (agriculture) THEN
+                   veget_max(:,2:nvm-2) = zero
+                   DO ji = 1, kjpindex
+                      veget_max(ji,1) = un - SUM(veget_max(ji,nvm-1:nvm)) &
+                           - SUM(frac_nobio(ji,:))
+                   ENDDO
+                ELSE
+                   veget_max(:,:) = zero
+                   DO ji = 1, kjpindex
+                      veget_max(ji,1) = un  - SUM(frac_nobio(ji,:))
+                   ENDDO
+                ENDIF
+                !
+             ENDIF
+             !
+          ENDIF
+          !
+       ELSE
+          ! WITH restarts for vegetation and DGVM and NO AGRICULTURE
+          IF ( control%ok_dgvm  ) THEN
+             !
+             ! If we are dealing with dynamic vegetation then all
+             ! natural PFTs should be set to veget_max = 0
+             !  And in case no agriculture is desired, agriculture PFTS should be
+             ! set to 0 as well
+             !
+             IF (.NOT. agriculture) THEN
+                DO ji = 1, kjpindex
+                   veget_max(ji,1) = veget_max(ji,1) + SUM(veget_max(ji,nvm-1:nvm))
+                ENDDO
+                veget_max(ji,nvm-1:nvm) = zero
+             ENDIF
+             !
+          ENDIF
+          !
+       ENDIF
+       !
+       totfrac_nobio(:) = zero
+       DO j = 1, nnobio
+          totfrac_nobio(:) = totfrac_nobio(:) + frac_nobio(:,j)
+       ENDDO
+       !
+       !
+       IF (read_lai) THEN
+
+          !Config Key  = SLOWPROC_LAI_OLD_INTERPOL
+          !Config Desc = Flag to use old "interpolation" of LAI
+          !Config If   = LAI_MAP
+          !Config Def  = FALSE
+          !Config Help = If you want to recover the old (ie orchidee_1_2 branch) 
+          !Config        "interpolation" of LAI map.
+          !
+          old_lai = .FALSE.
+          CALL getin_p('SLOWPROC_LAI_OLD_INTERPOL',old_lai)
+
+          !
+          !  In case the LAI map was not found in the restart then we need to recompute it
+          !
+          IF ( ALL( laimap(:,:,:) .EQ. val_exp) ) THEN
+             ! The interpolation of LAI has changed.
+             IF ( .NOT. old_lai ) THEN
+                ! NEW slowproc interlai :
+                CALL slowproc_interlai (kjpindex, lalo, resolution,  neighbours, contfrac, laimap)
+             ELSE
+                ! OLD slowproc interlai :
+                CALL slowproc_interlai(kjpindex, lalo,  resolution, laimap)
+             ENDIF
+             !
+             ! Compute the current LAI just to be sure 
+             !
+             stempdiag2_bid(1:kjpindex,1:nbdl) = stempdiag_bid
+             CALL slowproc_lai (kjpindex, lcanop, stempdiag2_bid, &
+                  lalo,resolution,lai,month,day,read_lai,laimap)
+             !
+             !  Make sure that we redo the computation when we will be back in slowproc_main
+             day_counter = dt_slow - dtradia
+             !
+          ENDIF
+          !
+       ENDIF
+       !
+       IF ( MINVAL(lai) .EQ. MAXVAL(lai) .AND. MAXVAL(lai) .EQ. val_exp) THEN
+          !
+          !  Get a first guess at the LAI
+          !
+          IF ( read_lai ) THEN
+             IF ( ALL( laimap(:,:,:) .EQ. val_exp) ) THEN
+                ! The interpolation of LAI has changed.
+                IF ( .NOT. old_lai ) THEN
+                   ! NEW slowproc interlai :
+                   CALL slowproc_interlai (kjpindex, lalo, resolution,  neighbours, contfrac, laimap)
+                ELSE
+                   ! OLD slowproc interlai :
+                   CALL slowproc_interlai(kjpindex, lalo,  resolution, laimap)
+                ENDIF
+             ENDIF
+          ENDIF
+          !
+          stempdiag2_bid(1:kjpindex,1:nbdl) = stempdiag_bid
+          CALL slowproc_lai (kjpindex, lcanop, stempdiag2_bid, &
+               lalo,resolution,lai,month,day,read_lai,laimap)
+
+          ! Make sure that we redo the computation when we will be back in slowproc_main
+          day_counter = dt_slow - dtradia
+
+       ENDIF
+
+       IF ( MINVAL(veget) .EQ. MAXVAL(veget) .AND. MAXVAL(veget) .EQ. val_exp) THEN
+
+          ! Impose height
+          DO jv = 1, nvm
+             height(:,jv) = height_presc(jv)
+          ENDDO
+
+          ! Have a first guess at the vegetation fraction
+          CALL slowproc_veget (kjpindex, lai, frac_nobio, veget_max, veget)
+
+       ENDIF
+
+       IF ( MINVAL(soiltype) .EQ. MAXVAL(soiltype) .AND. MAXVAL(soiltype) .EQ. val_exp .OR.&
+            & MINVAL(clayfraction) .EQ. MAXVAL(clayfraction) .AND. MAXVAL(clayfraction) .EQ. val_exp) THEN
+
+          CALL slowproc_soilt(kjpindex, lalo, neighbours, resolution, contfrac, soiltype, clayfraction)
+
+       ENDIF
+
+    ENDIF
+    !
+    ! Select the preferences for the distribution of the 13 PFTs on the 3 soil types.
+    !
+    vegsoil_dist='EQUI'
+    !
+    SELECT CASE(vegsoil_dist)
+       !
+       ! A reasonable choice
+       !
+    CASE('MAXR')
+       pref_soil_veg(:,1)  = (/ 1, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 /)
+       pref_soil_veg(:,2)  = (/ 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 /)
+       pref_soil_veg(:,3)  = (/ 3, 1, 1, 1, 1, 1 ,1 ,1 ,1 ,1 ,1 ,1, 1 /)
+       !
+       ! Current default : equidistribution.
+       !
+    CASE('EQUI')
+       !
+       pref_soil_veg(:,:) = zero
+       !
+    CASE DEFAULT
+       !
+       WRITE(numout,*) 'The vegetation soil type preference you have chosen does not exist'
+       WRITE(numout,*) 'You chose :', vegsoil_dist
+       STOP 'slowproc_init'
+       !
+    END SELECT
+    !
+    !
+    ! calculate total fraction of the mesh that is covered by particular surface types: ice, lakes, ...
+    !
+    totfrac_nobio(:) = zero
+    DO jv = 1, nnobio
+       totfrac_nobio(:) = totfrac_nobio(:) + frac_nobio(:,jv)
+    ENDDO
+
+    l_first_slowproc = .FALSE.
+
+    IF (long_print) WRITE (numout,*) ' slowproc_init done '
+
+  END SUBROUTINE slowproc_init
+  !!
+  !! Clear Memory
+  !!
+  SUBROUTINE slowproc_clear 
+
+
+    l_first_slowproc = .TRUE.
+    IF (ALLOCATED (clayfraction)) DEALLOCATE (clayfraction)
+    IF (ALLOCATED (laimap)) DEALLOCATE (laimap)
+    !
+    !
+    IF (ALLOCATED (veget_nextyear)) DEALLOCATE (veget_nextyear)
+    IF (ALLOCATED (frac_nobio_nextyear)) DEALLOCATE (frac_nobio_nextyear)
+    IF (ALLOCATED (totfrac_nobio_nextyear)) DEALLOCATE (totfrac_nobio_nextyear)
+    !
+    CALL stomate_clear 
+    !
+  END SUBROUTINE slowproc_clear
+  !!
+  !! Derive some variables
+  !!
+  SUBROUTINE slowproc_derivvar (kjpindex, veget, lai, &
+       qsintmax, deadleaf_cover, assim_param, height)
+
+    ! interface description
+    ! input scalar
+    INTEGER(i_std), INTENT (in)                                 :: kjpindex      !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)           :: veget         !! Fraction of vegetation type
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (in)           :: lai           !! Surface foliere
+    ! output scalar
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)          :: qsintmax      !! Maximum water on vegetation for interception
+    REAL(r_std),DIMENSION (kjpindex), INTENT (out)              :: deadleaf_cover!! fraction of soil covered by dead leaves
+    REAL(r_std), DIMENSION (kjpindex,nvm,npco2), INTENT (out)   :: assim_param   !! min+max+opt temps & vmax for photosynthesis
+    REAL(r_std),DIMENSION (kjpindex,nvm), INTENT (out)        :: height          !! height (m)
+    !
+    ! local declaration
+    !
+    INTEGER(i_std)       :: ji, jv
+
+    !
+    ! 1 Assimilation parameters
+    !
+    DO jv = 1, nvm
+       assim_param(:,jv,itmin) = co2_tmin_fix(jv) + tp_00
+       assim_param(:,jv,itopt) = co2_topt_fix(jv) + tp_00
+       assim_param(:,jv,itmax) = co2_tmax_fix(jv) + tp_00
+       assim_param(:,jv,ivcmax) = vcmax_fix(jv)
+       assim_param(:,jv,ivjmax) = vjmax_fix(jv)
+    ENDDO
+
+    !
+    ! 2 fraction of soil covered by dead leaves
+    !
+    deadleaf_cover(:) = zero
+
+    !
+    ! 3 height
+    !
+    DO jv = 1, nvm
+       height(:,jv) = height_presc(jv)
+    ENDDO
+    !
+    ! 4 qsintmax
+    !
+    qsintmax(:,:) = qsintcst * veget(:,:) * lai(:,:)
+    ! Ajout Nathalie - Juillet 2006
+    qsintmax(:,1) = zero
+
+  END SUBROUTINE slowproc_derivvar
+  !!
+  !!
+  !!
+  SUBROUTINE slowproc_mean (npts, n_dim2, dt_tot, dt, ldmean, field_in, field_mean)
+
+    ! Accumulates field_in over a period of dt_tot.
+    ! Has to be called at every time step (dt). 
+    ! Mean value is calculated if ldmean=.TRUE.
+    ! field_mean must be initialized outside of this routine!
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                          :: npts
+    ! 2nd dimension (1 or npft)
+    INTEGER(i_std), INTENT(in)                          :: n_dim2
+    ! Time step of STOMATE (days)
+    REAL(r_std), INTENT(in)                              :: dt_tot
+    ! Time step in days
+    REAL(r_std), INTENT(in)                              :: dt
+    ! Calculate mean ?
+    LOGICAL, INTENT(in)                                 :: ldmean
+    ! Daily field
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(in)      :: field_in
+
+    ! 0.2 modified field
+
+    ! Annual field
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(inout)   :: field_mean
+
+    ! =========================================================================
+
+    !
+    ! 1 accumulation
+    !
+
+    field_mean(:,:) = field_mean(:,:) + field_in(:,:) * dt
+
+    !
+    ! 2 mean fields
+    !
+
+    IF (ldmean) THEN
+       field_mean(:,:) = field_mean(:,:) / dt_tot
+    ENDIF
+
+  END SUBROUTINE slowproc_mean
+  !!
+  !!
+  !!
+  SUBROUTINE slowproc_long (npts, n_dim2, dt, tau, field_inst, field_long)
+
+    ! Calculates a temporally smoothed field (field_long) from instantaneous 
+    !   input fields.
+    ! Time constant tau determines the strength of the smoothing.
+    ! For tau -> infty, field_long becomes the true mean value of field_inst (but
+    !   the spinup becomes infinietly long, too).
+    ! field_long must be initialized outside of this routine!
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                 :: npts
+    ! 2nd dimension (1 or npft)
+    INTEGER(i_std), INTENT(in)                                 :: n_dim2
+    ! Time step
+    REAL(r_std), INTENT(in)                              :: dt
+    ! Integration time constant (has to have same unit as dt!)
+    REAL(r_std), INTENT(in)                              :: tau
+    ! Instantaneous field
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(in)      :: field_inst
+
+    ! 0.2 modified field
+
+    ! Long-term field
+    REAL(r_std), DIMENSION(npts,n_dim2), INTENT(inout)   :: field_long
+
+    ! =========================================================================
+
+    !
+    ! 1 test coherence
+    !
+
+    IF ( ( tau .LT. dt ) .OR. ( dt .LE. zero ) .OR. ( tau .LE. zero ) ) THEN
+       WRITE(numout,*) 'slowproc_long: Problem with time steps'
+       WRITE(numout,*) 'dt=',dt
+       WRITE(numout,*) 'tau=',tau
+    ENDIF
+
+    !
+    ! 2 integration
+    !
+
+    field_long(:,:) = ( field_inst(:,:)*dt + field_long(:,:)*(tau-dt) ) / tau
+
+  END SUBROUTINE slowproc_long
+  !!
+  !!
+  !!
+  SUBROUTINE slowproc_veget (kjpindex, lai, frac_nobio, veget_max, veget)
+    !
+    ! 0. Declarations
+    !
+
+    ! 0.1 Input
+    INTEGER(i_std), INTENT(in)                            :: kjpindex
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(in)       :: lai
+
+    ! 0.2 Modified
+    REAL(r_std), DIMENSION(kjpindex,nnobio), INTENT(inout) :: frac_nobio
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(inout)    :: veget_max
+
+    ! 0.3 Output
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)      :: veget
+
+    ! 0.4 Local
+    REAL(r_std), DIMENSION(kjpindex)                       :: fracsum
+    INTEGER(i_std)                                        :: nbad
+    INTEGER(i_std)                                        :: ji, jv
+    ! Test Nathalie	
+    REAL(r_std)						  :: SUMveg
+!!$    REAL(r_std)                                            :: trans_veg
+
+    !
+    ! 1. Sum up veget_max and frac_nobio and test if sum is equal to 1
+    !
+    !
+    ! 1.1 Sum up
+    !
+    fracsum(:) = zero
+    DO jv = 1, nnobio
+       DO ji = 1, kjpindex
+          fracsum(ji) = fracsum(ji) + frac_nobio(ji,jv)
+       ENDDO
+    ENDDO
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          fracsum(ji) = fracsum(ji) + veget_max(ji,jv)
+       ENDDO
+    ENDDO
+    !
+    ! 1.2 stop if there is a severe problem, that is an error above 0.01%
+    !     The rest will be scaled
+    !
+    nbad = COUNT( ABS(fracsum(:)-un) .GT. 0.0001 )
+    IF ( nbad .GT. 0 ) THEN
+      WRITE(numout,*) 'Problem with total surface areas.'
+      DO ji = 1, kjpindex
+        IF ( ABS(fracsum(ji)-un) .GT. 0.0001 ) THEN
+          WRITE(numout,*) 'Point :', ji
+          WRITE(numout,*) '  frac_nobio :', frac_nobio(ji,:)
+          WRITE(numout,*) '  Veget_max :', veget_max(ji,:)
+          WRITE(numout,*) '  Fracsum :', fracsum(ji), EPSILON(un)
+          WRITE(numout,*) '  The error is :', un - ( SUM(frac_nobio(ji,:)) + SUM(veget_max(ji,:)) )
+          STOP 'slowproc_veget'
+        ENDIF
+      ENDDO
+    ENDIF
+    !
+    ! 1.3 correction at places where the problem is surely precision-related
+    !
+    nbad = COUNT( ABS(fracsum(:)-un) .GT. EPSILON(un) )
+    !
+    IF ( nbad .GT. 0 ) THEN
+       !
+       IF ( long_print ) THEN
+          WRITE(numout,*) 'WARNING! scaling frac_nobio and veget_max at', nbad, ' points'
+       ENDIF
+       !
+       DO jv = 1, nnobio
+          DO ji = 1, kjpindex
+             IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
+                frac_nobio(ji,jv) = frac_nobio(ji,jv)/fracsum(ji)
+             ENDIF
+          ENDDO
+       ENDDO
+       !
+       DO jv = 1, nvm
+          DO ji = 1, kjpindex
+             IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
+                veget_max(ji,jv) = veget_max(ji,jv)/fracsum(ji)
+             ENDIF
+          ENDDO
+       ENDDO
+       !
+    ENDIF
+
+    !
+    ! 2. Set veget equal to veget_max
+    !
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          veget(ji,jv) = veget_max(ji,jv)
+       ENDDO
+    ENDDO
+    !
+    ! 3. if lai of a vegetation type (jv > 1) is small, increase soil part
+    !
+    ! Nathalie - nouveau calcul de veget
+!!$    DO jv = 1,nvm
+!!$       DO ji = 1, kjpindex
+!!$
+!!$          IF ((jv .GT. 1) .AND. (lai(ji,jv) .LT. 0.5)) THEN
+!!$             trans_veg = 2.*(0.5 - lai(ji,jv)) * veget(ji,jv)
+!!$             ! We limit the smallest fraction to 0.5%
+!!$             IF (  veget(ji,jv) - trans_veg .GT. min_vegfrac ) THEN
+!!$                veget(ji,1) = veget(ji,1) + trans_veg
+!!$                veget(ji,jv) = veget(ji,jv) - trans_veg
+!!$             ELSE
+!!$                veget(ji,1) = veget(ji,1) + veget(ji,jv)
+!!$                veget(ji,jv) = zero
+!!$             ENDIF
+!!$          ENDIF
+!!$
+!!$       ENDDO
+!!$    ENDDO
+    ! Ajout Nouveau calcul (stomate-like) 
+    DO ji = 1, kjpindex
+       SUMveg = zero
+       veget(ji,1) = veget_max(ji,1)
+       DO jv = 2, nvm
+          veget(ji,jv) = veget_max(ji,jv) * ( un - exp( - lai(ji,jv) * ext_coef(jv) ) )
+          veget(ji,1) = veget(ji,1) + (veget_max(ji,jv) - veget(ji,jv))
+          SUMveg = SUMveg + veget(ji,jv)
+       ENDDO
+       SUMveg = SUMveg + veget(ji,1) + SUM(frac_nobio(ji,:)) 
+       IF (SUMveg .LT. 0.99999) THEN
+          WRITE(numout,*)' ATTENTION, en ji, SUMveg LT 1: ', ji, SUMveg
+          WRITE(numout,*)'   frac_nobio = ',SUM(frac_nobio(ji,:))
+          WRITE(numout,*)  '              ',veget(ji,:)
+       ENDIF
+    ENDDO
+    !
+    ! 4. Sum up surface fractions and test if the sum is equal to 1
+    !
+
+    !
+    ! 4.1 Sum up
+    !
+    fracsum(:) = zero
+    DO jv = 1, nnobio
+       DO ji = 1, kjpindex
+          fracsum(ji) = fracsum(ji) + frac_nobio(ji,jv)
+       ENDDO
+    ENDDO
+    DO jv = 1, nvm
+       DO ji = 1, kjpindex
+          fracsum(ji) = fracsum(ji) + veget_max(ji,jv)
+       ENDDO
+    ENDDO
+
+    !
+    ! 4.2 stop if there is a severe problem
+    !
+    nbad = COUNT( ABS(fracsum(:)-un) .GT. (REAL(nvm+nnobio,r_std)*EPSILON(un)) )
+    !
+    IF ( nbad .GT. 0 ) THEN
+       WRITE(numout,*) 'Problem with veget or frac_nobio.'
+       DO ji = 1, kjpindex
+          IF ( ABS(fracsum(ji)-un) .GT. (10.*EPSILON(un)) ) THEN
+             WRITE(numout,*) 'Point :', ji
+             WRITE(numout,*) '  frac_nobio :', frac_nobio(ji,:)
+             WRITE(numout,*) '  Veget :', veget(ji,:)
+             WRITE(numout,*) '  The error is :', un - (SUM(frac_nobio(ji,:)) + SUM(veget(ji,:)))
+             STOP 'slowproc_veget'
+          ENDIF
+       ENDDO
+    ENDIF
+
+    ! 
+    ! 4.3 correction at places where the problem is surely precision-related
+    !
+    nbad = COUNT( ABS(fracsum(:)-un) .GT. EPSILON(un) )
+    !
+    IF ( nbad .GT. 0 ) THEN
+       !
+       IF ( long_print ) THEN
+          WRITE(numout,*) 'slowproc_veget: scaling veget at', nbad, ' points'
+       ENDIF
+       !
+       DO jv = 1, nvm
+          DO ji = 1, kjpindex
+             IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
+                veget(ji,jv) = veget(ji,jv) / fracsum(ji)
+             ENDIF
+          ENDDO
+       ENDDO
+       !
+       DO jv = 1, nnobio
+          DO ji = 1, kjpindex
+             IF ( ABS(fracsum(ji)-un) .GT. EPSILON(un) ) THEN
+                frac_nobio(ji,jv) = frac_nobio(ji,jv) / fracsum(ji)
+             ENDIF
+          ENDDO
+       ENDDO
+       !
+    ENDIF
+
+  END SUBROUTINE slowproc_veget
+  !!
+  !!
+  !!
+  SUBROUTINE slowproc_lai (kjpindex,lcanop,stempdiag,lalo,resolution,lai,mm,dd,read_lai,laimap)
+    !
+    ! 0. Declarations
+    !
+
+    ! 0.1 Input
+    INTEGER(i_std), INTENT(in)                         :: kjpindex   !! Domain size
+    INTEGER(i_std), INTENT(in)                         :: lcanop     !! soil level used for LAI
+    INTEGER(i_std), INTENT(in)                         :: mm, dd  
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)  :: stempdiag  !! Soil temperature
+    REAL(r_std),DIMENSION (kjpindex,2), INTENT (in)     :: lalo       !! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std), DIMENSION (kjpindex,2), INTENT(in)     :: resolution !! size in x an y of the grid (m)
+
+    REAL(r_std), DIMENSION(:,:,:), INTENT(in)           :: laimap     !! LAI lue
+    LOGICAL, INTENT(in)                                :: read_lai
+    ! 0.2 Output
+    REAL(r_std), DIMENSION(kjpindex,nvm), INTENT(out)   :: lai        !! LAI
+
+    ! 0.3 Local
+    INTEGER(i_std)                                     :: ji,jv
+
+    
+    ! Test Nathalie. On impose LAI PFT 1 a 0
+    ! On boucle sur 2,nvm au lieu de 1,nvm
+    lai(: ,1) = zero
+    DO jv = 2,nvm
+!!$    DO jv = 1,nvm
+
+       SELECT CASE (type_of_lai(jv))
+
+       CASE ("mean ")
+          !
+          ! 1. do the interpolation between laimax and laimin
+          !
+          IF ( .NOT. read_lai ) THEN
+             lai(:,jv) = undemi * (llaimax(jv) + llaimin(jv))
+          ELSE
+             DO ji = 1,kjpindex
+                lai(ji,jv) = MAXVAL(laimap(ji,jv,:))
+             ENDDO
+          ENDIF
+          !
+       CASE ("inter")
+          !
+          ! 2. do the interpolation between laimax and laimin
+          !
+          IF ( .NOT. read_lai ) THEN
+             DO ji = 1,kjpindex
+                lai(ji,jv) = llaimin(jv) + tempfunc(stempdiag(ji,lcanop)) * (llaimax(jv) - llaimin(jv))
+             ENDDO
+          ELSE
+             IF (mm .EQ. 1 ) THEN
+                IF (dd .LE. 15) THEN
+                   lai(:,jv) = laimap(:,jv,12)*(1-(dd+15)/30.) + laimap(:,jv,1)*((dd+15)/30.)
+                ELSE
+                   lai(:,jv) = laimap(:,jv,1)*(1-(dd-15)/30.) + laimap(:,jv,2)*((dd-15)/30.)
+                ENDIF
+             ELSE IF (mm .EQ. 12) THEN
+                IF (dd .LE. 15) THEN
+                   lai(:,jv) = laimap(:,jv,11)*(1-(dd+15)/30.) + laimap(:,jv,12)*((dd+15)/30.)
+                ELSE
+                   lai(:,jv) = laimap(:,jv,12)*(1-(dd-15)/30.) + laimap(:,jv,1)*((dd-15)/30.)
+                ENDIF
+             ELSE
+                IF (dd .LE. 15) THEN
+                   lai(:,jv) = laimap(:,jv,mm-1)*(1-(dd+15)/30.) + laimap(:,jv,mm)*((dd+15)/30.)
+                ELSE
+                   lai(:,jv) = laimap(:,jv,mm)*(1-(dd-15)/30.) + laimap(:,jv,mm+1)*((dd-15)/30.)
+                ENDIF
+             ENDIF
+          ENDIF
+          !
+       CASE default
+          !
+          ! 3. Problem
+          !
+          WRITE (numout,*) 'This kind of lai choice is not possible. '// &
+               ' We stop with type_of_lai ',jv,' = ', type_of_lai(jv) 
+          STOP 'slowproc_lai'
+
+       END SELECT
+
+    ENDDO
+
+  END SUBROUTINE slowproc_lai
+  !!
+  !! Interpolate the LAI map to the grid of the model 
+!MM TAG 1.6 model !
+  !!
+  SUBROUTINE slowproc_interlai_OLD(nbpt, lalo,  resolution, laimap)
+    !
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)          :: nbpt                  ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)             :: lalo(nbpt,2)          ! Vector of latitude and longitudes (beware of the order !)
+    REAL(r_std), INTENT(in)             :: resolution(nbpt,2)    ! The size in km of each grid-box in X and Y
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)    ::  laimap(nbpt,nvm,12)         ! lai read variable and re-dimensioned
+    !
+    !  0.3 LOCAL
+    !
+    REAL(r_std), PARAMETER                          :: min_sechiba=1.E-8
+    !
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, ijml, i, j, ik, lml, tml, fid, ib, jb,ip, jp, vid, ai,iki,jkj
+    REAL(r_std) :: lev(1), date, dt, coslat, pi
+    INTEGER(i_std) :: itau(1)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) ::  mask_lu
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu, mask
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: laimaporig
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: laimap_lu
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_up, lon_low, lat_up, lat_low
+    INTEGER, DIMENSION(nbpt) :: n_origlai
+    INTEGER, DIMENSION(nbpt) :: n_found
+    REAL(r_std), DIMENSION(nbpt,nvm) :: frac_origlai
+
+    CHARACTER(LEN=80) :: meter
+    REAL(r_std) :: prog, sumf
+    LOGICAL :: found
+    INTEGER :: idi,jdi, ilast, jlast, jj, ii, jv, inear, iprog
+    REAL(r_std) :: domaine_lon_min, domaine_lon_max, domaine_lat_min, domaine_lat_max
+    !
+    pi = 4. * ATAN(1.)
+    !
+    !Config Key  = LAI_FILE
+    !Config Desc = Name of file from which the vegetation map is to be read
+    !Config If   = !LAI_MAP
+    !Config Def  = ../surfmap/lai2D.nc
+    !Config Help = The name of the file to be opened to read the LAI
+    !Config        map is to be given here. Usualy SECHIBA runs with a 5kmx5km
+    !Config        map which is derived from a Nicolas VIOVY one. 
+    !
+    filename = 'lai2D.nc'
+    CALL getin_p('LAI_FILE',filename)
+    !
+    IF (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
+    CALL bcast(iml)
+    CALL bcast(jml)
+    CALL bcast(lml)
+    CALL bcast(tml)
+    !
+    !
+    ALLOCATE(lon_lu(iml))
+    ALLOCATE(lat_lu(jml))
+    ALLOCATE(laimap_lu(iml,jml,nvm,tml))
+    ALLOCATE(mask_lu(iml,jml))
+    !
+    WRITE(numout,*) 'slowproc_interlai : Reading the LAI file'
+    !
+    IF (is_root_prc) THEN
+       CALL flinget(fid, 'longitude', iml, 0, 0, 0, 1, 1, lon_lu)
+       CALL flinget(fid, 'latitude', jml, 0, 0, 0, 1, 1, lat_lu)
+       CALL flinget(fid, 'LAI', iml, jml, nvm, tml, 1, 12, laimap_lu)
+       CALL flinget(fid, 'mask', iml, jml, 0, 0, 0, 1, mask_lu)
+       !
+       CALL flinclo(fid)
+    ENDIF
+    CALL bcast(lon_lu)
+    CALL bcast(lat_lu)
+    CALL bcast(laimap_lu)
+    CALL bcast(mask_lu)
+    !
+    WRITE(numout,*) 'slowproc_interlai : ', lon_lu(1), lon_lu(iml),lat_lu(1), lat_lu(jml)
+    !
+    !
+    ijml=iml*jml
+    ALLOCATE(lon_ful(ijml))
+    ALLOCATE(lat_ful(ijml))
+    ALLOCATE(laimaporig(ijml,nvm,tml))
+    ALLOCATE(mask(ijml))
+
+    DO i=1,iml
+       DO j=1,jml
+          iki=(j-1)*iml+i
+          lon_ful(iki)=lon_lu(i)
+          lat_ful(iki)=lat_lu(j)
+          laimaporig(iki,:,:)=laimap_lu(i,j,:,:)
+          mask(iki)=mask_lu(i,j)
+       ENDDO
+    ENDDO
+    !
+    WHERE  ( laimaporig(:,:,:) .LT. 0 )
+       laimaporig(:,:,:) = zero
+    ENDWHERE
+    !
+    !
+    ALLOCATE(lon_up(nbpt)) 
+    ALLOCATE(lon_low(nbpt))
+    ALLOCATE(lat_up(nbpt))
+    ALLOCATE(lat_low(nbpt))
+    !
+    DO ib =1, nbpt
+       !
+       !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+       !  into longitudes and latitudes we do not have the problem of periodicity.
+       !  coslat is a help variable here !
+       !
+       coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
+       !
+       lon_up(ib) = lalo(ib,2) + resolution(ib,1)/(2.0*coslat) 
+       lon_low(ib) = lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+       !
+       coslat = pi/180. * R_Earth
+       !
+       lat_up(ib) = lalo(ib,1) + resolution(ib,2)/(2.0*coslat) 
+       lat_low(ib) = lalo(ib,1) - resolution(ib,2)/(2.0*coslat) 
+       !
+       !
+       !
+    ENDDO
+    lon_up = NINT( lon_up * 1E6 ) * 1E-6
+    lon_low = NINT( lon_low * 1E6 ) * 1E-6
+    lat_up = NINT( lat_up * 1E6 ) * 1E-6
+    lat_low = NINT( lat_low * 1E6 ) * 1E-6
+    !
+    !  Get the limits of the integration domaine so that we can speed up the calculations
+    !
+    domaine_lon_min = MINVAL(lon_low)
+    domaine_lon_max = MAXVAL(lon_up)
+    domaine_lat_min = MINVAL(lat_low)
+    domaine_lat_max = MAXVAL(lat_up)
+    !
+!!$    WRITE(*,*) 'DOMAINE lon :', domaine_lon_min, domaine_lon_max
+!!$    WRITE(*,*) 'DOMAINE lat :', domaine_lat_min, domaine_lat_max
+    !
+    ! Ensure that the fine grid covers the whole domain
+    WHERE ( lon_ful(:) .LT. domaine_lon_min )
+      lon_ful(:) = lon_ful(:) + 360.
+    ENDWHERE
+    !
+    WHERE ( lon_ful(:) .GT. domaine_lon_max )
+      lon_ful(:) = lon_ful(:) - 360.
+    ENDWHERE
+    lon_ful = NINT( lon_ful * 1E6 ) * 1E-6
+    lat_ful = NINT( lat_ful * 1E6 ) * 1E-6
+    !
+    WRITE(numout,*) 'Interpolating the lai map :'
+    WRITE(numout,'(2a40)')'0%--------------------------------------', &
+                   & '------------------------------------100%'
+    !
+    ilast = 1
+    n_origlai(:) = 0
+    laimap(:,:,:) = zero    
+    !
+    DO ip=1,ijml
+       !
+       !   Give a progress meter
+       !
+       ! prog = ip/float(ijml)*79.
+       !  IF ( ABS(prog - NINT(prog)) .LT. 1/float(ijml)*79. ) THEN
+       !   meter(NINT(prog)+1:NINT(prog)+1) = 'x'
+       !   WRITE(numout, advance="no", FMT='(a)') ACHAR(13)
+       !   WRITE(numout, advance="no", FMT='(a80)') meter
+       ! ENDIF
+       iprog = NINT(float(ip)/float(ijml)*79.) - NINT(float(ip-1)/float(ijml)*79.)
+       IF ( iprog .NE. 0 ) THEN
+          WRITE(numout,'(a1,$)') 'y'
+       ENDIF
+       !
+       !  Only start looking for its place in the smaler grid if we are within the domaine
+       !  That should speed up things !
+       !
+       IF ( ( lon_ful(ip) .GE. domaine_lon_min ) .AND. &
+            ( lon_ful(ip) .LE. domaine_lon_max ) .AND. &
+            ( lat_ful(ip) .GE. domaine_lat_min ) .AND. &
+            ( lat_ful(ip) .LE. domaine_lat_max )        ) THEN
+          !
+          ! look for point on GCM grid which this point on fine grid belongs to.
+          ! First look at the point on the model grid where we arrived just before. There is 
+          ! a good chace that neighbouring points on the fine grid fall into the same model
+          ! grid box.
+          !
+          IF ( ( lon_ful(ip) .GE. lon_low(ilast) ) .AND. &
+               ( lon_ful(ip) .LT. lon_up(ilast) ) .AND. &
+               ( lat_ful(ip) .GE. lat_low(ilast) ) .AND. &
+               ( lat_ful(ip) .LT. lat_up(ilast) )         ) THEN
+             !
+             ! We were lucky
+             !
+             IF (mask(ip) .GT. 0) THEN
+                n_origlai(ilast) =  n_origlai(ilast) + 1  
+                DO i=1,nvm
+                   DO j=1,12   
+                      laimap(ilast,i,j) = laimap(ilast,i,j) + laimaporig(ip,i,j)
+                   ENDDO
+                ENDDO
+             ENDIF
+             !
+          ELSE
+             !
+             ! Otherwise, look everywhere.
+             ! Begin close to last grid point.
+             !
+             found = .FALSE. 
+             idi = 1
+             !
+             DO WHILE ( (idi .LT. nbpt) .AND. ( .NOT. found ) )
+
+                !
+                ! forward and backward
+                !
+                DO ii = 1,2
+                   !
+                   IF ( ii .EQ. 1 ) THEN
+                      ib = ilast - idi
+                   ELSE
+                      ib = ilast + idi
+                   ENDIF
+                   !
+                   IF ( ( ib .GE. 1 ) .AND. ( ib .LE. nbpt ) ) THEN 
+                      IF ( ( lon_ful(ip) .GE. lon_low(ib) ) .AND. &
+                           ( lon_ful(ip) .LT. lon_up(ib) ) .AND. &
+                           ( lat_ful(ip) .GE. lat_low(ib) ) .AND. &
+                           ( lat_ful(ip) .LT. lat_up(ib) )         ) THEN
+                         !
+                         IF (mask(ip) .gt. 0) THEN
+                            DO i=1,nvm
+                               DO j=1,12                
+                                  laimap(ib,i,j) = laimap(ib,i,j) + laimaporig(ip,i,j) 
+                               ENDDO
+                            ENDDO
+                            n_origlai(ib) =  n_origlai(ib) + 1
+                         ENDIF
+                         ilast = ib
+                         found = .TRUE.
+                         !
+                      ENDIF
+                   ENDIF
+                   !
+                ENDDO
+                !
+                idi = idi + 1
+                !
+             ENDDO
+             !
+          ENDIF ! lucky/not lucky
+          !
+       ENDIF     ! in the domain
+    ENDDO
+
+
+    ! determine fraction of LAI points in each box of the coarse grid
+    DO ip=1,nbpt
+       IF ( n_origlai(ip) .GT. 0 ) THEN
+          DO jv =1,nvm
+             laimap(ip,jv,:) = laimap(ip,jv,:)/REAL(n_origlai(ip),r_std)
+          ENDDO
+       ELSE
+          !
+          ! Now we need to handle some exceptions
+          !
+          IF ( lalo(ip,1) .LT. -56.0) THEN
+             ! Antartica
+             DO jv =1,nvm
+                laimap(ip,jv,:) = zero
+             ENDDO
+             !
+          ELSE IF ( lalo(ip,1) .GT. 70.0) THEN
+             ! Artica
+             DO jv =1,nvm
+                laimap(ip,jv,:) = zero
+             ENDDO
+             !
+          ELSE IF ( lalo(ip,1) .GT. 55.0 .AND. lalo(ip,2) .GT. -65.0 .AND. lalo(ip,2) .LT. -20.0) THEN
+             ! Greenland
+             DO jv =1,nvm
+                laimap(ip,jv,:) = zero
+             ENDDO
+             !
+          ELSE
+             !
+             WRITE(numout,*) 'PROBLEM, no point in the lai map found for this grid box'
+             WRITE(numout,*) 'Longitude range : ', lon_low(ip), lon_up(ip)
+             WRITE(numout,*) 'Latitude range : ', lat_low(ip), lat_up(ip)
+             !
+             WRITE(numout,*) 'Looking for nearest point on the lai map file'
+             CALL slowproc_nearest (ijml, lon_ful, lat_ful, &
+                  lalo(ip,2), lalo(ip,1), inear)
+             WRITE(numout,*) 'Coordinates of the nearest point, ',inear,' :', &
+                  lon_ful(inear),lat_ful(inear)
+             !
+             DO jv =1,nvm
+                laimap(ip,jv,:) = laimaporig(inear,jv,:)
+             ENDDO
+          ENDIF
+       ENDIF
+    ENDDO
+    ! 
+    WRITE(numout,*) 'slowproc_interlai : Interpolation Done'
+    !
+    !  
+    !
+    DEALLOCATE(lon_up)
+    DEALLOCATE(lon_low)
+    DEALLOCATE(lat_up)
+    DEALLOCATE(lat_low)
+    DEALLOCATE(lat_ful)
+    DEALLOCATE(lon_ful)
+    DEALLOCATE(lat_lu)
+    DEALLOCATE(lon_lu)
+    DEALLOCATE(laimap_lu)
+    DEALLOCATE(laimaporig)
+    DEALLOCATE(mask_lu)
+    DEALLOCATE(mask)
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_interlai_OLD
+  !!
+  !! Interpolate the LAI map to the grid of the model
+  !!
+  SUBROUTINE slowproc_interlai_NEW(nbpt, lalo,  resolution, neighbours, contfrac, laimap)
+    !
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)          :: nbpt                  ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)             :: lalo(nbpt,2)          ! Vector of latitude and longitudes (beware of the order !)
+    REAL(r_std), INTENT(in)             :: resolution(nbpt,2)    ! The size in km of each grid-box in X and Y
+    !
+    INTEGER(i_std), INTENT(in)         :: neighbours(nbpt,8)  ! Vector of neighbours for each grid point (1=N, 2=E, 3=S, 4=W)
+    REAL(r_std), INTENT(in)             :: contfrac(nbpt)     ! Fraction of land in each grid box.
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)    ::  laimap(nbpt,nvm,12)         ! lai read variable and re-dimensioned
+    !
+    !  0.3 LOCAL
+    !
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, it, jj, jv
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat, lon
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: sub_area
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: laimap_lu
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    !
+    REAL(r_std) :: totarea
+    INTEGER(i_std) :: idi, nbvmax
+    CHARACTER(LEN=30) :: callsign
+    !
+    LOGICAL ::           ok_interpol  ! optionnal return of aggregate_2d
+    !
+    INTEGER                  :: ALLOC_ERR
+    !
+    !Config Key  = LAI_FILE
+    !Config Desc = Name of file from which the vegetation map is to be read
+    !Config If   = LAI_MAP
+    !Config Def  = ../surfmap/lai2D.nc
+    !Config Help = The name of the file to be opened to read the LAI
+    !Config        map is to be given here. Usualy SECHIBA runs with a 5kmx5km
+    !Config        map which is derived from a Nicolas VIOVY one. 
+    !
+    filename = 'lai2D.nc'
+    CALL getin_p('LAI_FILE',filename)
+    !
+    IF (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
+    CALL bcast(iml)
+    CALL bcast(jml)
+    CALL bcast(lml)
+    CALL bcast(tml)
+    !
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(lon_lu(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon_lu : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(lat_lu(jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_lu : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(laimap_lu(iml,jml,nvm,tml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of laimap_lu : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    !
+    IF (is_root_prc) THEN
+       CALL flinget(fid, 'longitude', iml, 0, 0, 0, 1, 1, lon_lu)
+       CALL flinget(fid, 'latitude', jml, 0, 0, 0, 1, 1, lat_lu)
+       CALL flinget(fid, 'LAI', iml, jml, nvm, tml, 1, 12, laimap_lu)
+       !
+       WHERE (laimap_lu(:,:,:,:) < zero )
+          laimap_lu(:,:,:,:) = zero
+       ENDWHERE
+       !
+       CALL flinclo(fid)
+    ENDIF
+    CALL bcast(lon_lu)
+    CALL bcast(lat_lu)
+    CALL bcast(laimap_lu)
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(lon(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(lat(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    DO ip=1,iml
+       lat(ip,:) = lat_lu(:)
+    ENDDO
+    DO jp=1,jml
+       lon(:,jp) = lon_lu(:)
+    ENDDO
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    ! Consider all points a priori
+    !
+!!$    mask(:,:) = 1
+    mask(:,:) = 0
+    !
+    DO ip=1,iml
+       DO jp=1,jml
+          !
+          ! Exclude the points where there is never a LAI value. It is probably 
+          ! an ocean point.
+          !
+!!$          IF (ABS(SUM(laimap_lu(ip,jp,:,:))) < EPSILON(laimap_lu) ) THEN
+!!$             mask(ip,jp) = 0
+!!$          ENDIF
+          !
+          IF ( ANY(laimap_lu(ip,jp,:,:) < 20.) ) THEN
+             mask(ip,jp) = 1
+          ENDIF
+          !
+       ENDDO
+    ENDDO
+    !
+    nbvmax = 20
+    !
+    callsign = 'LAI map'
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+       WRITE(numout,*) "nbvmax = ",nbvmax
+       !
+       ALLOC_ERR=-1
+       ALLOCATE(sub_index(nbpt, nbvmax, 2), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_index(:,:,:)=0
+       ALLOC_ERR=-1
+       ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_area(:,:)=zero
+       !
+       CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
+            &                iml, jml, lon, lat, mask, callsign, &
+            &                nbvmax, sub_index, sub_area, ok_interpol)
+       
+       !
+       IF ( .NOT. ok_interpol ) THEN
+          DEALLOCATE(sub_area)
+          DEALLOCATE(sub_index)
+       ENDIF
+       !
+       nbvmax = nbvmax * 2
+    ENDDO
+    !
+    laimap(:,:,:) = zero
+    !
+    DO ib=1,nbpt
+       idi = COUNT(sub_area(ib,:) > zero)
+       IF ( idi > 0 ) THEN
+          totarea = zero
+          DO jj=1,idi
+             ip = sub_index(ib,jj,1)
+             jp = sub_index(ib,jj,2)
+             DO jv=1,nvm
+                DO it=1,12
+                   laimap(ib,jv,it) = laimap(ib,jv,it) + laimap_lu(ip,jp,jv,it)*sub_area(ib,jj)
+                ENDDO
+             ENDDO
+             totarea = totarea + sub_area(ib,jj)
+          ENDDO
+          !
+          ! Normalize
+          !
+          laimap(ib,:,:) = laimap(ib,:,:)/totarea
+          
+!!$          IF ( ANY( laimap(ib,:,:) > 10 ) ) THEN
+!!$             WRITE(numout,*) "For point ",ib
+!!$             WRITE(numout,*) lalo(ib,1), lalo(ib,2)
+!!$             WRITE(numout,*) "For ib=",ib," we have LAI ",laimap(ib,:,1:idi)
+!!$             WRITE(numout,*) "Detail of projection :" 
+!!$             WRITE(numout,*) sub_area(ib,1:idi)
+!!$             WRITE(numout,*) "Total for projection :" ,totarea
+!!$          ENDIF
+          !
+       ELSE
+          WRITE(numout,*) 'On point ', ib, ' no points where found for interpolating the LAI map.'
+          WRITE(numout,*) 'Location : ', lalo(ib,2), lalo(ib,1)
+          DO jv=1,nvm
+             laimap(ib,jv,:) = (llaimax(jv)+llaimin(jv))/deux
+          ENDDO
+          WRITE(numout,*) 'Solved by putting the average LAI for the PFT all year long'
+       ENDIF
+    ENDDO
+    !
+    WRITE(numout,*) 'slowproc_interlai : Interpolation Done'
+    !
+    !  
+    !
+    DEALLOCATE(lat_lu)
+    DEALLOCATE(lon_lu)
+    DEALLOCATE(lon)
+    DEALLOCATE(lat)
+    DEALLOCATE(laimap_lu)
+    DEALLOCATE(mask)
+    DEALLOCATE(sub_area)
+    DEALLOCATE(sub_index)
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_interlai_NEW
+  !!
+  !! Interpolate a vegetation map (by pft)
+  !!
+!MM modif TAG 1.4 : 
+!  SUBROUTINE slowproc_update(nbpt, lalo,  resolution, vegetmap, frac_nobiomap)
+!MM modif TAG 1.9.2 : 
+!  SUBROUTINE slowproc_update(nbpt, lalo, neighbours,  resolution, contfrac, vegetmax, frac_nobio, veget_year, init)
+  SUBROUTINE slowproc_update(nbpt, lalo, neighbours,  resolution, contfrac, & 
+       &       veget_last, frac_nobio_last, & 
+       &       veget_next, frac_nobio_next, veget_year, init)
+    !
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)                             :: nbpt            ! Number of points for which the data needs 
+                                                                              ! to be interpolated
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)             :: lalo            ! Vector of latitude and longitudes (beware of the order !)
+!MM modif TAG 1.4 : add grid variables for aggregate
+    INTEGER(i_std), DIMENSION(nbpt,8), INTENT(in)         :: neighbours      ! Vector of neighbours for each grid point 
+    ! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    REAL(r_std), DIMENSION(nbpt,2), INTENT(in)             :: resolution      ! The size in km of each grid-box in X and Y
+    REAL(r_std), DIMENSION(nbpt), INTENT(in)               :: contfrac        ! Fraction of continent in the grid
+    !
+    REAL(r_std), DIMENSION(nbpt,nvm), INTENT(in)           :: veget_last  ! old max vegetfrac
+    REAL(r_std), DIMENSION(nbpt,nnobio), INTENT(in)        :: frac_nobio_last ! old fraction of the mesh which is 
+    ! covered by ice, lakes, ...
+    !
+    INTEGER(i_std), INTENT(in)         :: veget_year            ! first year for landuse (0 == NO TIME AXIS)
+    LOGICAL, OPTIONAL, INTENT(in)      :: init            ! initialisation : in case of dgvm, it forces update of all PFTs
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), DIMENSION(nbpt,nvm), INTENT(out)          :: veget_next       ! new max vegetfrac
+    REAL(r_std), DIMENSION(nbpt,nnobio), INTENT(out)       :: frac_nobio_next  ! new fraction of the mesh which is 
+    ! covered by ice, lakes, ...
+    !
+    !  0.3 LOCAL
+    !
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, inobio, jv
+    INTEGER(i_std) :: nb_coord,nb_var, nb_gat,nb_dim
+    REAL(r_std) :: date, dt
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:)  :: itau
+    REAL(r_std), DIMENSION(1)  :: time_counter
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_lu, lon_lu
+    INTEGER,DIMENSION(flio_max_var_dims) :: l_d_w, i_d_w
+    LOGICAL :: exv, l_ex
+    !
+!MM modif TAG 1.4 : suppression of all time axis reading and interpolation, replaced by each year 2D reading.
+!    REAL(r_std), INTENT(inout)    ::  vegetmap(nbpt,nvm,293)         ! vegetfrac read variable and re-dimensioned
+!    REAL(r_std), INTENT(inout)    ::  frac_nobiomap(nbpt,nnobio,293) ! Fraction of the mesh which is covered by ice, lakes, ...
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:,:) :: vegmap            ! last coord is time with only one value = 1
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:,:) :: vegmap_1            ! last coord is time with only one value = 1  (IF VEGET_YEAR == 0 , NO TIME AXIS)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_ful, lon_ful
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)    :: sub_area
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    !
+    REAL(r_std) :: sumf, err, norm
+    REAL(r_std) :: totarea
+    INTEGER(i_std) :: idi, nbvmax
+    CHARACTER(LEN=30) :: callsign
+    !
+    LOGICAL ::           ok_interpol ! optionnal return of aggregate_2d
+    !
+    ! for DGVM case :
+    REAL(r_std)                 :: sum_veg                     ! sum of vegets
+    REAL(r_std)                 :: sum_nobio                   ! sum of nobios
+    REAL(r_std)                 :: sumvAnthro_old, sumvAnthro  ! last an new sum of antrhopic vegets
+    REAL(r_std)                 :: rapport                     ! (S-B) / (S-A)
+    LOGICAL                    :: partial_update              ! if TRUE, partialy update PFT (only anthropic ones) 
+                                                              ! e.g. in case of DGVM and not init (optional parameter)
+    !
+    LOGICAL, PARAMETER         :: debug = .FALSE.
+    !
+    INTEGER                  :: ALLOC_ERR
+    !
+    !Config Key  = VEGETATION_FILE
+    !Config Desc = Name of file from which the vegetation map is to be read
+    !Config If   = LAND_USE
+    !Config Def  = pft_new.nc
+    !Config Help = The name of the file to be opened to read a vegetation
+    !Config        map (in pft) is to be given here. 
+    !
+    filename = 'pft_new.nc'
+    CALL getin_p('VEGETATION_FILE',filename)
+    !
+    IF (is_root_prc) THEN
+       IF (debug) THEN
+          WRITE(numout,*) "Entering slowproc_update. Debug mode."
+          WRITE (*,'(/," --> fliodmpf")')
+          CALL fliodmpf (TRIM(filename))
+          WRITE (*,'(/," --> flioopfd")')
+       ENDIF
+       CALL flioopfd (TRIM(filename),fid,nb_dim=nb_coord,nb_var=nb_var,nb_gat=nb_gat)
+       IF (debug) THEN
+          WRITE (*,'(" Number of coordinate        in the file : ",I2)') nb_coord
+          WRITE (*,'(" Number of variables         in the file : ",I2)') nb_var
+          WRITE (*,'(" Number of global attributes in the file : ",I2)') nb_gat
+       ENDIF
+    ENDIF
+    CALL bcast(nb_coord)
+    CALL bcast(nb_var)
+    CALL bcast(nb_gat)
+    IF ( veget_year > 0 ) THEN
+       IF (is_root_prc) &
+         CALL flioinqv (fid,v_n="time_counter",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w) 
+       CALL bcast(l_d_w)
+       tml=l_d_w(1)
+       WRITE(numout,*) "tml =",tml
+    ENDIF
+    IF (is_root_prc) &
+         CALL flioinqv (fid,v_n="lon",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w) 
+    CALL bcast(l_d_w)
+    iml=l_d_w(1)
+    WRITE(numout,*) "iml =",iml
+    
+    IF (is_root_prc) &
+         CALL flioinqv (fid,v_n="lat",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w) 
+    CALL bcast(l_d_w)
+    jml=l_d_w(1)
+    WRITE(numout,*) "jml =",jml
+    
+    IF (is_root_prc) &
+         CALL flioinqv (fid,v_n="veget",l_ex=l_ex,nb_dims=nb_dim,len_dims=l_d_w) 
+    CALL bcast(l_d_w)
+    lml=l_d_w(1)
+
+    IF (lml /= nvm) &
+         CALL ipslerr (3,'slowproc_update', &
+               &          'Problem with vegetation file for Land Use','lml /= nvm', &
+               &          '(number of pft must be equal)')
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(lat_lu(jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_lu : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(lon_lu(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon_lu : ",ALLOC_ERR
+      STOP 
+    ENDIF
+
+    IF ( veget_year > 0 ) THEN
+       IF (tml > 0) THEN
+          ALLOC_ERR=-1
+          ALLOCATE(itau(tml), STAT=ALLOC_ERR)
+          IF (ALLOC_ERR/=0) THEN
+             WRITE(numout,*) "ERROR IN ALLOCATION of itau : ",ALLOC_ERR
+             STOP 
+          ENDIF
+       ENDIF
+       !
+       IF (is_root_prc) THEN
+          IF (tml > 0) THEN
+             CALL fliogstc (fid, t_axis=itau,x_axis=lon_lu,y_axis=lat_lu)
+             IF (veget_year <= tml) THEN
+                CALL fliogetv (fid,"time_counter",time_counter, start=(/ veget_year /), count=(/ 1 /))
+                WRITE(numout,*) "slowproc_update LAND_USE : the date read for vegetmax is ",time_counter
+             ELSE
+                CALL fliogetv (fid,"time_counter",time_counter, start=(/ tml /), count=(/ 1 /))
+                WRITE(numout,*) "slowproc_update LAND_USE : You try to update vegetmax with a the date greater than in the file."
+                WRITE(numout,*) "                           We will keep the last one :",time_counter
+             ENDIF
+          ELSE
+             CALL fliogstc (fid, x_axis=lon_lu,y_axis=lat_lu)
+          ENDIF
+       ENDIF
+    ENDIF
+    IF (tml > 0) THEN
+       CALL bcast(itau)
+    ENDIF
+    CALL bcast(lon_lu)
+    CALL bcast(lat_lu)
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(lat_ful(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(lon_ful(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    DO ip=1,iml
+       lon_ful(ip,:)=lon_lu(ip)
+    ENDDO
+    DO jp=1,jml
+       lat_ful(:,jp)=lat_lu(jp)
+    ENDDO
+    !
+    !
+    WRITE(numout,*) 'Reading the LAND USE vegetation file'
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(vegmap(iml,jml,nvm,1), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    IF ( veget_year == 0 ) THEN
+       IF (is_root_prc) THEN
+          ALLOC_ERR=-1
+          ALLOCATE(vegmap_1(iml,jml,nvm), STAT=ALLOC_ERR)
+          IF (ALLOC_ERR/=0) THEN
+             WRITE(numout,*) "ERROR IN ALLOCATION of vegmap_1 : ",ALLOC_ERR
+             STOP 
+          ENDIF
+       ENDIF
+    ENDIF
+    !
+!!$    CALL flinopen &
+!!$       &  (filename, .FALSE., iml, jml, lml, lon_ful, lat_ful, &
+!!$       &   lev_ful, tml, itau, date, dt, fid)
+!=> FATAL ERROR FROM ROUTINE flinopen
+! --> No time axis found
+
+!MM modif TAG 1.4 : 
+!    CALL flinget(fid, 'lon', iml, 0, 0, 0, 1, 1, lon_lu)
+!    CALL flinget(fid, 'lat', jml, 0, 0, 0, 1, 1, lat_lu)
+!    CALL flinget(fid, 'maxvegetfrac', iml, jml, nvm, tml, 1, 293, vegmap_lu)
+!FATAL ERROR FROM ROUTINE flinopen
+! --> No variable lon
+!   We get only the right year
+!!$    CALL flinget(fid, 'maxvegetfrac', iml, jml, nvm, tml, veget_year, veget_year, vegmap)
+!!$    !
+!!$    CALL flinclo(fid)
+
+    IF (is_root_prc) &
+         CALL flioinqv (fid,"maxvegetfrac",exv,nb_dims=nb_dim,len_dims=l_d_w,id_dims=i_d_w)
+    CALL bcast(exv)
+    CALL bcast(nb_dim)
+    CALL bcast(l_d_w)
+    CALL bcast(i_d_w)
+
+    IF (exv) THEN
+       IF (debug) THEN
+          WRITE (numout,'(" Number of dimensions : ",I2)') nb_dim
+          WRITE (numout,'(" Dimensions :",/,5(1X,I7,:))') l_d_w(1:nb_dim)
+          WRITE (numout,'(" Identifiers :",/,5(1X,I7,:))') i_d_w(1:nb_dim)
+       ENDIF
+       !
+       IF ( veget_year > 0 ) THEN
+          IF (is_root_prc) THEN
+             IF (veget_year <= tml) THEN
+                CALL fliogetv (fid,"maxvegetfrac", vegmap, start=(/ 1, 1, 1, veget_year /), count=(/ iml, jml, nvm, 1 /))
+             ELSE
+                CALL fliogetv (fid,"maxvegetfrac", vegmap, start=(/ 1, 1, 1, tml /), count=(/ iml, jml, nvm, 1 /))
+             ENDIF
+          ENDIF
+       ELSE
+          IF (is_root_prc) THEN
+             CALL fliogetv (fid,"maxvegetfrac", vegmap_1, start=(/ 1, 1, 1 /), count=(/ iml, jml, nvm /))
+             vegmap(:,:,:,1)=vegmap_1(:,:,:)
+             DEALLOCATE(vegmap_1)
+          ENDIF
+       ENDIF
+       CALL bcast(vegmap)
+       IF (is_root_prc) CALL flioclo (fid)
+    ELSE
+       CALL ipslerr (3,'slowproc_update', &
+            &          'Problem with vegetation file for Land Use.', &
+            &          "Variable maxvegetfrac doesn't exist.", &
+            &          '(verify your land use file.)')
+    ENDIF
+    !
+    ! Mask of permitted variables.
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    mask(:,:) = 0
+    DO ip=1,iml
+       DO jp=1,jml
+          sum_veg=SUM(vegmap(ip,jp,:,1))
+          IF ( sum_veg .GE. min_sechiba .AND. sum_veg .LE. 1.-1.e-7) THEN
+             mask(ip,jp) = 1
+             IF (debug) THEN
+                WRITE(numout,*) "update : SUM(vegmap(",ip,jp,")) = ",sum_veg
+             ENDIF
+          ELSEIF ( sum_veg .GT. 1.-1.e-7 .AND. sum_veg .LE. 2.) THEN
+             ! normalization
+             vegmap(ip,jp,:,1) = vegmap(ip,jp,:,1) / sum_veg
+             mask(ip,jp) = 1
+             IF (debug) THEN
+                WRITE(numout,*) "update : SUM(vegmap(",ip,jp,"))_c = ",SUM(vegmap(ip,jp,:,1))
+             ENDIF
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    !
+    ! The number of maximum vegetation map points in the GCM grid should
+    ! also be computed and not imposed here.
+    !
+    nbvmax = 200
+    !
+    callsign="Land Use Vegetation map"
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+       WRITE(numout,*) "nbvmax = ",nbvmax
+       !
+       ALLOC_ERR=-1
+       ALLOCATE(sub_index(nbpt, nbvmax,2), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_index(:,:,:)=0
+
+       ALLOC_ERR=-1
+       ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_area(:,:)=zero
+       !
+       CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
+            &                iml, jml, lon_ful, lat_ful, mask, callsign, &
+            &                nbvmax, sub_index, sub_area, ok_interpol)
+       !
+       IF ( .NOT. ok_interpol ) THEN
+          DEALLOCATE(sub_area)
+          DEALLOCATE(sub_index)
+       ENDIF
+       !
+       nbvmax = nbvmax * 2
+    ENDDO
+    !
+    ! Compute the logical for partial (only anthropic) PTFs update
+    IF (PRESENT(init)) THEN
+       partial_update = control%ok_dgvm  .AND. .NOT. init
+    ELSE
+       partial_update = control%ok_dgvm  
+    ENDIF
+    !
+    IF ( .NOT. partial_update ) THEN
+       !
+       veget_next(:,:)=zero
+       !
+       DO ib = 1, nbpt
+          idi=1
+          sumf=zero
+          DO WHILE ( sub_area(ib,idi) > zero ) 
+             ip = sub_index(ib,idi,1)
+             jp = sub_index(ib,idi,2)
+             veget_next(ib,:) = veget_next(ib,:) + vegmap(ip,jp,:,1)*sub_area(ib,idi)
+             sumf=sumf + sub_area(ib,idi)
+             idi = idi +1
+          ENDDO
+!!$          !
+!!$          !  Limit the smalest vegetation fraction to 0.5%
+!!$          !
+!!$          DO jv = 1, nvm
+!!$             IF ( veget_next(ib,jv) .LT. min_vegfrac ) THEN
+!!$                veget_next(ib,jv) = zero
+!!$             ENDIF
+!!$          ENDDO
+          !
+          ! Normalize
+          !
+          IF (sumf > min_sechiba) THEN
+             veget_next(ib,:) = veget_next(ib,:) / sumf
+          ELSE
+             WRITE(numout,*) "slowproc_update : No land point in the map for point ",&
+                  ib,",(",lalo(ib,1),",",lalo(ib,2),")" 
+             CALL ipslerr (2,'slowproc_update', &
+                  &          'Problem with vegetation file for Land Use.', &
+                  &          "No land point in the map for point", &
+                  &          'Keep old values. (verify your land use file.)')
+!!$             CALL slowproc_nearest (iml, lon_ful, lat_ful, &
+!!$                  lalo(ib,2), lalo(ib,1), inear)
+             IF (PRESENT(init)) THEN
+                IF (init) THEN
+                   veget_next(ib,:) = (/ 1., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0. /)
+                ELSE
+                   veget_next(ib,:) = veget_last(ib,:)
+                ENDIF
+             ELSE
+                veget_next(ib,:) = veget_last(ib,:)
+             ENDIF
+          ENDIF
+          !
+          IF (debug) THEN
+             WRITE(numout,*) "SUM(veget_next(",ib,")) = ",SUM(veget_next(ib,:))
+          ENDIF
+       ENDDO
+    ELSE
+       DO ib = 1, nbpt
+          ! last veget for this point
+          sum_veg=SUM(veget_last(ib,:))
+          IF (debug) THEN
+             WRITE(*,*) "SUM(veget_last(",ib,")) = ",sum_veg
+          ENDIF
+          !
+          ! If the DGVM is activated, only anthropiques PFT are utpdated,
+          ! other are copied 
+          veget_next(ib,:) = veget_last(ib,:)
+          !
+          ! natural ones are initialized to zero.
+          DO jv = 2, nvm
+             ! If the DGVM is activated, only anthropiques PFT are utpdated 
+             IF ( .NOT. natural(jv) ) THEN
+                veget_next(ib,jv) = zero
+             ENDIF
+          ENDDO
+          !
+          idi=1
+          sumf=zero
+          DO WHILE ( sub_area(ib,idi) > zero ) 
+             ip = sub_index(ib,idi,1)
+             jp = sub_index(ib,idi,2)
+             ! If the DGVM is activated, only anthropic PFTs are utpdated 
+             DO jv = 2, nvm
+                IF ( .NOT. natural(jv) ) THEN       
+                   veget_next(ib,jv) = veget_next(ib,jv) + vegmap(ip,jp,jv,1)*sub_area(ib,idi)
+                ENDIF
+             ENDDO
+             sumf=sumf + sub_area(ib,idi)
+             idi = idi +1
+          ENDDO
+!!$          !
+!!$          !  Limit the smalest vegetation fraction to 0.5%
+!!$          !
+!!$          DO jv = 2, nvm
+!!$             ! On anthropic and natural PFTs ? 
+!!$             IF ( veget_next(ib,jv) .LT. min_vegfrac ) THEN
+!!$                veget_next(ib,jv) = zero
+!!$             ENDIF
+!!$          ENDDO
+          !
+          ! Normalize
+          !
+          ! Proposition de Pierre :
+          ! apres modification de la surface des PFTs anthropiques,
+          ! on doit conserver la proportion des PFTs naturels.
+          ! ie la somme des vegets est conservee
+          !    et PFT naturel / (somme des vegets - somme des vegets anthropiques)
+          !       est conservee.
+          ! Sum veget_next = old (sum veget_next Naturel) + (sum veget_next Anthropic) 
+          !           = new (sum veget_next Naturel) + (sum veget_next Anthropic)
+          !    a / (S-A) = e / (S-B) ; b/(S-A) = f/(S-B)
+          IF (sumf > min_sechiba) THEN
+             sumvAnthro_old = zero
+             sumvAnthro     = zero
+             DO jv = 2, nvm
+                IF ( .NOT. natural(jv) ) THEN
+                   veget_next(ib,jv) = veget_next(ib,jv) / sumf
+                   sumvAnthro = sumvAnthro + veget_last(ib,jv)
+                   sumvAnthro_old = sumvAnthro_old + veget_last(ib,jv)
+                ENDIF
+             ENDDO
+             ! conservation :
+             rapport = ( sum_veg - sumvAnthro ) / ( sum_veg - sumvAnthro_old )
+             veget_next(ib,1) = veget_last(ib,1) * rapport
+             DO jv = 2, nvm
+                IF ( .NOT. natural(jv) ) THEN
+                   veget_next(ib,jv) = veget_last(ib,jv) * rapport
+                ENDIF
+             ENDDO
+             ! test
+             IF ( ABS( SUM(veget_next(ib,:)) - sum_veg ) > EPSILON(un) ) THEN
+                WRITE(numout,*) "No conservation of sum of veget for point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")" 
+                WRITE(numout,*) "last sum of veget ",sum_veg," new sum of veget ",SUM(veget_next(ib,:))," error : ",&
+                     &                         SUM(veget_next(ib,:)) - sum_veg
+                WRITE(numout,*) "Anthropic modificaztions : last ",sumvAnthro_old," new ",sumvAnthro                
+                CALL ipslerr (3,'slowproc_update', &
+                     &          'No conservation of sum of veget_next', &
+                     &          "The sum of veget_next is different after reading Land Use map.", &
+                  &          '(verify the dgvm case model.)')
+             ENDIF
+          ELSE
+             WRITE(numout,*) "No land point in the map for point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")" 
+!             CALL ipslerr (3,'slowproc_update', &
+             CALL ipslerr (2,'slowproc_update', &
+                  &          'Problem with vegetation file for Land Use.', &
+                  &          "No land point in the map for point", &
+                  &          '(verify your land use file.)')
+             veget_next(ib,:) = veget_last(ib,:)
+          ENDIF
+          
+       ENDDO       
+    ENDIF
+    !
+    frac_nobio_next (:,:) = un
+    !
+!MM
+    ! Work only for one nnobio !! (ie ice)
+    DO inobio=1,nnobio
+       DO jv=1,nvm
+          !
+          DO ib = 1, nbpt
+             frac_nobio_next(ib,inobio) = frac_nobio_next(ib,inobio) - veget_next(ib,jv)
+          ENDDO
+       ENDDO
+       !
+    ENDDO
+    !
+    DO ib = 1, nbpt
+       sum_veg = SUM(veget_next(ib,:))
+       sum_nobio = SUM(frac_nobio_next(ib,:))
+       IF (sum_nobio < 0.) THEN
+          frac_nobio_next(ib,:) = zero
+          veget_next(ib,1) = veget_next(ib,1) - sum_nobio
+          sum_veg = SUM(veget_next(ib,:))
+       ENDIF
+       sumf = sum_veg + sum_nobio
+       IF (sumf > min_sechiba) THEN
+          veget_next(ib,:) = veget_next(ib,:) / sumf
+          frac_nobio_next(ib,:) = frac_nobio_next(ib,:) / sumf
+          norm=SUM(veget_next(ib,:))+SUM(frac_nobio_next(ib,:))
+          err=norm-un
+          IF (debug) &
+             WRITE(numout,*) "ib ",ib," SUM(veget_next(ib,:)+frac_nobio_next(ib,:))-un, sumf",err,sumf
+          IF (abs(err) > -EPSILON(un)) THEN
+!MM 1.9.3
+!          IF (abs(err) > 0.) THEN
+             IF ( SUM(frac_nobio_next(ib,:)) > min_sechiba ) THEN
+                frac_nobio_next(ib,1) = frac_nobio_next(ib,1) - err
+             ELSE
+                veget_next(ib,1) = veget_next(ib,1) - err
+             ENDIF
+             norm=SUM(veget_next(ib,:))+SUM(frac_nobio_next(ib,:))
+             err=norm-un
+             IF (debug) &
+                  WRITE(numout,*) "ib ",ib," SUM(veget_next(ib,:)+frac_nobio_next(ib,:))-un",err
+             IF (abs(err) > EPSILON(un)) THEN
+!MM 1.9.3
+!             IF (abs(err) > 0.) THEN
+                WRITE(numout,*) "update : Problem with point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")" 
+                WRITE(numout,*) "         err(sum-1.) = ",abs(err)
+                CALL ipslerr (2,'slowproc_update', &
+                     &          'Problem with sum vegetation + sum fracnobio for Land Use.', &
+                     &          "sum not equal to 1.", &
+                     &          '(verify your land use file.)')
+             ENDIF
+          ENDIF
+       ELSE
+          WRITE(numout,*) "No vegetation nor frac_nobio for point ",ib,",(",lalo(ib,1),",",lalo(ib,2),")" 
+          WRITE(numout,*)"Replaced by bare_soil !! "
+          veget_next(ib,1) = un
+          veget_next(ib,2:nvm) = zero
+          frac_nobio_next(ib,:) = zero
+!!$          CALL ipslerr (3,'slowproc_update', &
+!!$               &          'Problem with vegetation file for Land Use.', &
+!!$               &          "No vegetation nor frac_nobio for point ", &
+!!$               &          '(verify your land use file.)')
+       ENDIF
+    ENDDO
+    !
+    WRITE(numout,*) 'slowproc_update : Interpolation Done'
+    !
+    DEALLOCATE(vegmap)
+    DEALLOCATE(lat_lu,lon_lu)
+    DEALLOCATE(lat_ful,lon_ful)
+    DEALLOCATE(mask)
+    DEALLOCATE(sub_index,sub_area)
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_update
+
+  !!
+  !! Interpolate the IGBP vegetation map to the grid of the model
+!MM TAG 1.6 model !
+  !!
+  SUBROUTINE slowproc_interpol_OLD(nbpt, lalo, neighbours, resolution, veget, frac_nobio )
+  !
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)          :: nbpt                  ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)             :: lalo(nbpt,2)          ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)          :: neighbours(nbpt,8)    ! Vector of neighbours for each grid point 
+                                                                ! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    REAL(r_std), INTENT(in)             :: resolution(nbpt,2)    ! The size in km of each grid-box in X and Y
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)    ::  veget(nbpt,nvm)         ! Vegetation fractions
+    REAL(r_std), INTENT(out)    ::  frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
+    !
+    !  0.3 LOCAL
+    !
+    REAL(r_std), PARAMETER                          :: min_sechiba=1.E-8
+    INTEGER(i_std), PARAMETER                       :: nolson = 94  ! Number of Olson classes
+    !
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, vid
+    REAL(r_std) :: lev(1), date, dt, coslat, pi
+    INTEGER(i_std) :: itau(1)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_up, lon_low, lat_up, lat_low
+    INTEGER, DIMENSION(nbpt,nolson) :: n_origveg
+    INTEGER, DIMENSION(nbpt) :: n_found
+    REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
+    REAL(r_std) :: vegcorr(nolson,nvm)
+    REAL(r_std) :: nobiocorr(nolson,nnobio)
+    CHARACTER(LEN=80) :: meter
+    REAL(r_std) :: prog, sumf
+    LOGICAL :: found
+    INTEGER :: idi, ilast, ii, jv, inear, iprog
+    REAL(r_std) :: domaine_lon_min, domaine_lon_max, domaine_lat_min, domaine_lat_max
+    !
+    pi = 4. * ATAN(1.)
+    !
+    CALL get_vegcorr (nolson,vegcorr,nobiocorr)
+    !
+    !Config Key  = VEGETATION_FILE
+    !Config Desc = Name of file from which the vegetation map is to be read
+    !Config If   = !IMPOSE_VEG
+    !Config Def  = ../surfmap/carteveg5km.nc
+    !Config Help = The name of the file to be opened to read the vegetation
+    !Config        map is to be given here. Usualy SECHIBA runs with a 5kmx5km
+    !Config        map which is derived from the IGBP one. We assume that we have
+    !Config        a classification in 87 types. This is Olson modified by Viovy.
+    !
+    filename = '../surfmap/carteveg5km.nc'
+    CALL getin_p('VEGETATION_FILE',filename)
+    !
+    if (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
+    CALL bcast(iml)
+    CALL bcast(jml)
+    CALL bcast(lml)
+    CALL bcast(tml)
+    !
+    !
+    ALLOCATE(lat_ful(iml))
+    ALLOCATE(lon_ful(iml))
+    ALLOCATE(vegmap(iml))
+    !
+    WRITE(numout,*) 'Reading the vegetation file'
+    !
+    IF (is_root_prc) THEN
+       CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
+       CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
+       CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
+       !
+       CALL flinclo(fid)
+    ENDIF
+    
+    CALL bcast(lon_ful)
+    CALL bcast(lat_ful)
+    CALL bcast(vegmap)
+    
+    !
+    IF (MAXVAL(vegmap) .LT. nolson) THEN
+      WRITE(*,*) 'WARNING -- WARNING'
+      WRITE(*,*) 'The vegetation map has to few vegetation types.'
+      WRITE(*,*) 'If you are lucky it will work but please check'
+    ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
+      WRITE(*,*) 'More vegetation types in file than the code can'
+      WRITE(*,*) 'deal with.: ',  MAXVAL(vegmap),  nolson
+      STOP 'slowproc_interpol'
+    ENDIF
+    !
+    ALLOCATE(lon_up(nbpt)) 
+    ALLOCATE(lon_low(nbpt))
+    ALLOCATE(lat_up(nbpt))
+    ALLOCATE(lat_low(nbpt))
+    !
+    DO ib =1, nbpt
+       !
+       !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+       !  into longitudes and latitudes we do not have the problem of periodicity.
+       !  coslat is a help variable here !
+       !
+       coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
+       !
+       lon_up(ib) = lalo(ib,2) + resolution(ib,1)/(2.0*coslat) 
+       lon_low(ib) = lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+       !
+       coslat = pi/180. * R_Earth
+       !
+       lat_up(ib) = lalo(ib,1) + resolution(ib,2)/(2.0*coslat) 
+       lat_low(ib) = lalo(ib,1) - resolution(ib,2)/(2.0*coslat) 
+       !
+       !
+       veget(ib,:) = zero
+       frac_nobio (ib,:) = zero
+       !
+    ENDDO
+    !
+    !  Get the limits of the integration domaine so that we can speed up the calculations
+    !
+    domaine_lon_min = MINVAL(lon_low)
+    domaine_lon_max = MAXVAL(lon_up)
+    domaine_lat_min = MINVAL(lat_low)
+    domaine_lat_max = MAXVAL(lat_up)
+    !
+!!$    WRITE(*,*) 'DOMAINE lon :', domaine_lon_min, domaine_lon_max
+!!$    WRITE(*,*) 'DOMAINE lat :', domaine_lat_min, domaine_lat_max
+    !
+    ! Ensure that the fine grid covers the whole domain
+    WHERE ( lon_ful(:) .LT. domaine_lon_min )
+      lon_ful(:) = lon_ful(:) + 360.
+    ENDWHERE
+    !
+    WHERE ( lon_ful(:) .GT. domaine_lon_max )
+      lon_ful(:) = lon_ful(:) - 360.
+    ENDWHERE
+    !
+    WRITE(numout,*) 'Interpolating the vegetation map :'
+    WRITE(numout,'(2a40)')'0%--------------------------------------', &
+                   & '------------------------------------100%'
+    !
+    ilast = 1
+    n_origveg(:,:) = 0
+    !
+    DO ip=1,iml
+      !
+      !   Give a progress meter
+      !
+      ! prog = ip/float(iml)*79.
+      !  IF ( ABS(prog - NINT(prog)) .LT. 1/float(iml)*79. ) THEN
+      !   meter(NINT(prog)+1:NINT(prog)+1) = 'x'
+      !   WRITE(numout, advance="no", FMT='(a)') ACHAR(13)
+      !   WRITE(numout, advance="no", FMT='(a80)') meter
+      ! ENDIF
+      iprog = NINT(float(ip)/float(iml)*79.) - NINT(float(ip-1)/float(iml)*79.)
+      IF ( iprog .NE. 0 ) THEN
+        WRITE(numout,'(a1,$)') 'x'
+      ENDIF
+      !
+      !  Only start looking for its place in the smaler grid if we are within the domaine
+      !  That should speed up things !
+      !
+      IF ( ( lon_ful(ip) .GE. domaine_lon_min ) .AND. &
+           ( lon_ful(ip) .LE. domaine_lon_max ) .AND. &
+           ( lat_ful(ip) .GE. domaine_lat_min ) .AND. &
+           ( lat_ful(ip) .LE. domaine_lat_max )        ) THEN
+        !
+        ! look for point on GCM grid which this point on fine grid belongs to.
+        ! First look at the point on the model grid where we arrived just before. There is 
+        ! a good chace that neighbouring points on the fine grid fall into the same model
+        ! grid box.
+        !
+        !
+        ! THERE IS A BUG HERE !!! IF THE GCM GRID SITS ON THE DATE LINE WE WILL HAVE FOR INSTANCE
+        ! LON_LOW = -182 AND LON_UP = -178. THUS WE WILL ONLY PICK UP HALF THE POINTS NEEDED.
+        !
+        IF ( ( lon_ful(ip) .GT. lon_low(ilast) ) .AND. &
+             ( lon_ful(ip) .LT. lon_up(ilast) ) .AND. &
+             ( lat_ful(ip) .GT. lat_low(ilast) ) .AND. &
+             ( lat_ful(ip) .LT. lat_up(ilast) )         ) THEN
+          !
+          ! We were lucky
+          !
+          n_origveg(ilast,NINT(vegmap(ip))) = n_origveg(ilast,NINT(vegmap(ip))) + 1
+          !
+        ELSE
+          !
+          ! Otherwise, look everywhere.
+          ! Begin close to last grid point.
+          !
+          found = .FALSE. 
+          idi = 1
+          !
+          DO WHILE ( (idi .LT. nbpt) .AND. ( .NOT. found ) )
+            !
+            ! forward and backward
+            !
+            DO ii = 1,2
+              !
+              IF ( ii .EQ. 1 ) THEN
+                ib = ilast - idi
+              ELSE
+                ib = ilast + idi
+              ENDIF
+              !
+              IF ( ( ib .GE. 1 ) .AND. ( ib .LE. nbpt ) ) THEN
+                IF ( ( lon_ful(ip) .GT. lon_low(ib) ) .AND. &
+                     ( lon_ful(ip) .LT. lon_up(ib) ) .AND. &
+                     ( lat_ful(ip) .GT. lat_low(ib) ) .AND. &
+                     ( lat_ful(ip) .LT. lat_up(ib) )         ) THEN
+                  !
+                  n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + 1
+                  ilast = ib
+                  found = .TRUE.
+                  !
+                ENDIF
+              ENDIF
+              !
+            ENDDO
+            !
+            idi = idi + 1
+            !
+          ENDDO
+          !
+        ENDIF ! lucky/not lucky
+        !
+      ENDIF     ! in the domain
+    ENDDO
+
+    !
+    ! Now we know how many points of which Olson type from the fine grid fall
+    ! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
+    !
+
+    !
+    ! determine number of points of the fine grid which fall into each box of the 
+    ! coarse grid
+    !
+    DO ib = 1, nbpt
+      n_found(ib) = SUM( n_origveg(ib,:) )
+    ENDDO
+
+    !
+    ! determine fraction of Olson vegetation type in each box of the coarse grid
+    !
+    DO vid = 1, nolson
+      WHERE ( n_found(:) .GT. 0 ) 
+        frac_origveg(:,vid) =  REAL(n_origveg(:,vid),r_std) /  REAL(n_found(:),r_std)
+      ELSEWHERE
+         frac_origveg(:,vid) = zero
+      ENDWHERE
+    ENDDO
+
+    !
+    ! now finally calculate coarse vegetation map
+    ! Find which model vegetation corresponds to each Olson type 
+    !
+    DO vid = 1, nolson
+      !
+      DO jv = 1, nvm
+        veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
+      ENDDO
+      !
+      DO jv = 1, nnobio
+        frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
+      ENDDO
+      !
+    ENDDO
+    !
+    !
+    WRITE(numout,*)
+    WRITE(numout,*) 'Interpolation Done'
+    !
+    !   Clean up the point of the map
+    !
+    DO ib = 1, nbpt
+       !
+       !  Let us see if all points found something in the 5km map !
+       !
+       IF ( n_found(ib) .EQ. 0 ) THEN
+          !
+          ! Now we need to handle some exceptions
+          !
+          IF ( lalo(ib,1) .LT. -56.0) THEN
+             ! Antartica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
+             ! Artica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
+             ! Greenland
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE
+             !
+             WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box'
+             WRITE(numout,*) 'Longitude range : ', lon_low(ib), lon_up(ib)
+             WRITE(numout,*) 'Latitude range : ', lat_low(ib), lat_up(ib)
+             !
+             WRITE(numout,*) 'Looking for nearest point on the 5 km map'
+             CALL slowproc_nearest (iml, lon_ful, lat_ful, &
+                                    lalo(ib,2), lalo(ib,1), inear)
+             WRITE(numout,*) 'Coordinates of the nearest point:', &
+                              lon_ful(inear),lat_ful(inear)
+             !
+             DO jv = 1, nvm
+               veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+             DO jv = 1, nnobio
+               frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+          ENDIF
+          !
+       ENDIF
+       !
+       !
+       !  Limit the smalest vegetation fraction to 0.5%
+       !
+       DO vid = 1, nvm
+          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
+             veget(ib,vid) = zero
+          ENDIF
+       ENDDO
+       !
+       sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
+       frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
+       veget(ib,:) = veget(ib,:)/sumf
+       !
+       !       
+    ENDDO
+    !
+    DEALLOCATE(lon_up)
+    DEALLOCATE(lon_low)
+    DEALLOCATE(lat_up)
+    DEALLOCATE(lat_low)
+    DEALLOCATE(lat_ful)
+    DEALLOCATE(lon_ful)
+    DEALLOCATE(vegmap)
+    !
+    RETURN
+    !
+ END SUBROUTINE slowproc_interpol_OLD
+  !!
+  !! Interpolate the IGBP vegetation map to the grid of the model
+  !!
+  SUBROUTINE slowproc_interpol_NEW(nbpt, lalo, neighbours, resolution, contfrac, veget, frac_nobio )
+    !
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)          :: nbpt                  ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)              :: lalo(nbpt,2)          ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)          :: neighbours(nbpt,8)    ! Vector of neighbours for each grid point 
+    ! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    REAL(r_std), INTENT(in)              :: resolution(nbpt,2)    ! The size in km of each grid-box in X and Y
+    REAL(r_std),DIMENSION (nbpt), INTENT (in) :: contfrac         !! Fraction of continent in the grid
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)    ::  veget(nbpt,nvm)         ! Vegetation fractions
+    REAL(r_std), INTENT(out)    ::  frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
+    !
+    LOGICAL ::           ok_interpol  ! optionnal return of aggregate_vec
+    !
+    !  0.3 LOCAL
+    !
+    INTEGER(i_std), PARAMETER                       :: nolson = 94  ! Number of Olson classes
+    !
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, vid
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
+    INTEGER(i_std),ALLOCATABLE, DIMENSION(:,:) :: sub_index
+    REAL(r_std), DIMENSION(nbpt,nolson) :: n_origveg
+    REAL(r_std), DIMENSION(nbpt) :: n_found
+    REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
+    REAL(r_std) :: vegcorr(nolson,nvm)
+    REAL(r_std) :: nobiocorr(nolson,nnobio)
+    CHARACTER(LEN=40) :: callsign
+    REAL(r_std) :: sumf, resol_lon, resol_lat
+    INTEGER(i_std) :: idi, jv, inear, nbvmax
+    !
+    INTEGER                  :: ALLOC_ERR
+    !
+    n_origveg(:,:) = zero
+    n_found(:) = zero
+    !
+    CALL get_vegcorr (nolson,vegcorr,nobiocorr)
+    !
+    !Config Key  = VEGETATION_FILE
+    !Config Desc = Name of file from which the vegetation map is to be read
+    !Config If   = !IMPOSE_VEG
+    !Config If   = !LAND_USE
+    !Config Def  = ../surfmap/carteveg5km.nc
+    !Config Help = The name of the file to be opened to read the vegetation
+    !Config        map is to be given here. Usualy SECHIBA runs with a 5kmx5km
+    !Config        map which is derived from the IGBP one. We assume that we have
+    !Config        a classification in 87 types. This is Olson modified by Viovy.
+    !
+    filename = '../surfmap/carteveg5km.nc'
+    CALL getin_p('VEGETATION_FILE',filename)
+    !
+    if (is_root_prc) CALL flininfo(filename, iml, jml, lml, tml, fid)
+    CALL bcast(iml)
+    CALL bcast(jml)
+    CALL bcast(lml)
+    CALL bcast(tml)
+    !
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(lat_ful(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(lon_ful(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(vegmap(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    WRITE(numout,*) 'Reading the OLSON type vegetation file'
+    !
+    IF (is_root_prc) THEN
+       CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
+       CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
+       CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
+       !
+       CALL flinclo(fid)
+    ENDIF
+    
+    CALL bcast(lon_ful)
+    CALL bcast(lat_ful)
+    CALL bcast(vegmap)
+    
+    !
+    IF (MAXVAL(vegmap) .LT. nolson) THEN
+       WRITE(numout,*) 'WARNING -- WARNING'
+       WRITE(numout,*) 'The vegetation map has to few vegetation types.'
+       WRITE(numout,*) 'If you are lucky it will work but please check'
+    ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
+       WRITE(numout,*) 'More vegetation types in file than the code can'
+       WRITE(numout,*) 'deal with.: ',  MAXVAL(vegmap),  nolson
+       STOP 'slowproc_interpol'
+    ENDIF
+    !
+    ! Some assumptions on the vegetation file. This information should be
+    ! be computed or read from the file. 
+    ! It is the reolution in meters of the grid of the vegetation file.
+    !
+    resol_lon = 5000.
+    resol_lat = 5000.
+    !
+    ! The number of maximum vegetation map points in the GCM grid should
+    ! also be computed and not imposed here.
+    nbvmax = iml/nbpt
+    !
+    callsign="Vegetation map"
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+       WRITE(numout,*) "nbvmax = ",nbvmax
+       !
+       ALLOC_ERR=-1
+       ALLOCATE(sub_index(nbpt, nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_index(:,:)=0
+       ALLOC_ERR=-1
+       ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_area(:,:)=zero
+       !
+       CALL aggregate_p (nbpt, lalo, neighbours, resolution, contfrac, &
+            &                iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign, &
+            &                nbvmax, sub_index, sub_area, ok_interpol)
+       !
+       IF ( .NOT. ok_interpol ) THEN
+          DEALLOCATE(sub_area)
+          DEALLOCATE(sub_index)
+          !
+          nbvmax = nbvmax * 2
+       ELSE
+          !
+          DO ib = 1, nbpt
+             idi=1
+             DO WHILE ( sub_area(ib,idi) > zero ) 
+                ip = sub_index(ib,idi)
+                n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + sub_area(ib,idi)
+                n_found(ib) =  n_found(ib) + sub_area(ib,idi)
+                idi = idi +1
+             ENDDO
+          ENDDO
+          !
+       ENDIF
+    ENDDO
+    !
+    ! Now we know how many points of which Olson type from the fine grid fall
+    ! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
+    !
+    !
+    ! determine fraction of Olson vegetation type in each box of the coarse grid
+    !
+    DO vid = 1, nolson
+       WHERE ( n_found(:) .GT. 0 ) 
+          frac_origveg(:,vid) = n_origveg(:,vid) / n_found(:)
+       ELSEWHERE
+          frac_origveg(:,vid) = zero
+       ENDWHERE
+    ENDDO
+    !
+    ! now finally calculate coarse vegetation map
+    ! Find which model vegetation corresponds to each Olson type 
+    !
+    veget(:,:) = zero
+    frac_nobio(:,:) = zero
+    !
+    DO vid = 1, nolson
+       !
+       DO jv = 1, nvm
+          veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
+       ENDDO
+       !
+       DO jv = 1, nnobio
+          frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
+       ENDDO
+       !
+    ENDDO
+    !
+    WRITE(numout,*) 'slowproc_interpol : Interpolation Done'
+    !
+    !   Clean up the point of the map
+    !
+    DO ib = 1, nbpt
+       !
+       !  Let us see if all points found something in the 5km map !
+       !
+       IF ( n_found(ib) .EQ. 0 ) THEN
+          !
+          ! Now we need to handle some exceptions
+          !
+          IF ( lalo(ib,1) .LT. -56.0) THEN
+             ! Antartica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
+             ! Artica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
+             ! Greenland
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE
+             !
+             WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box',ib
+             WRITE(numout,*) 'Longitude range : ', lalo(ib,2)
+             WRITE(numout,*) 'Latitude range : ', lalo(ib,1)
+             !
+             WRITE(numout,*) 'Looking for nearest point on the 5 km map'
+             CALL slowproc_nearest (iml, lon_ful, lat_ful, &
+                  lalo(ib,2), lalo(ib,1), inear)
+             WRITE(numout,*) 'Coordinates of the nearest point:', &
+                  lon_ful(inear),lat_ful(inear)
+             !
+             DO jv = 1, nvm
+                veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+             DO jv = 1, nnobio
+                frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+          ENDIF
+          !
+       ENDIF
+       !
+       !
+       !  Limit the smalest vegetation fraction to 0.5%
+       !
+       DO vid = 1, nvm
+          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
+             veget(ib,vid) = zero
+          ENDIF
+       ENDDO
+       !
+       sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
+       frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
+       veget(ib,:) = veget(ib,:)/sumf
+       !
+       !       
+    ENDDO
+    !
+    DEALLOCATE(vegmap)
+    DEALLOCATE(lat_ful, lon_ful)
+    DEALLOCATE(sub_index)
+    DEALLOCATE(sub_area)
+
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_interpol_NEW
+
+  !!
+  !! Interpolate the IGBP vegetation map to the grid of the model
+!MM TAG 1.6 model !
+  !!
+  SUBROUTINE slowproc_interpol_OLD_g(nbpt, lalo, neighbours, resolution, veget, frac_nobio )
+  !
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)          :: nbpt                  ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)             :: lalo(nbpt,2)          ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)          :: neighbours(nbpt,8)    ! Vector of neighbours for each grid point 
+                                                                ! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    REAL(r_std), INTENT(in)             :: resolution(nbpt,2)    ! The size in km of each grid-box in X and Y
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)    ::  veget(nbpt,nvm)         ! Vegetation fractions
+    REAL(r_std), INTENT(out)    ::  frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
+    !
+    !  0.3 LOCAL
+    !
+    REAL(r_std), PARAMETER                          :: min_sechiba=1.E-8
+    INTEGER(i_std), PARAMETER                       :: nolson = 94  ! Number of Olson classes
+    !
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, vid
+    REAL(r_std) :: lev(1), date, dt, coslat, pi
+    INTEGER(i_std) :: itau(1)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lon_up, lon_low, lat_up, lat_low
+    INTEGER, DIMENSION(nbpt,nolson) :: n_origveg
+    INTEGER, DIMENSION(nbpt) :: n_found
+    REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
+    REAL(r_std) :: vegcorr(nolson,nvm)
+    REAL(r_std) :: nobiocorr(nolson,nnobio)
+    CHARACTER(LEN=80) :: meter
+    REAL(r_std) :: prog, sumf
+    LOGICAL :: found
+    INTEGER :: idi, ilast, ii, jv, inear, iprog
+    REAL(r_std) :: domaine_lon_min, domaine_lon_max, domaine_lat_min, domaine_lat_max
+    !
+    pi = 4. * ATAN(1.)
+    !
+    CALL get_vegcorr (nolson,vegcorr,nobiocorr)
+    !
+    !Config Key  = VEGETATION_FILE
+    !Config Desc = Name of file from which the vegetation map is to be read
+    !Config If   = !IMPOSE_VEG
+    !Config Def  = ../surfmap/carteveg5km.nc
+    !Config Help = The name of the file to be opened to read the vegetation
+    !Config        map is to be given here. Usualy SECHIBA runs with a 5kmx5km
+    !Config        map which is derived from the IGBP one. We assume that we have
+    !Config        a classification in 87 types. This is Olson modified by Viovy.
+    !
+    filename = '../surfmap/carteveg5km.nc'
+    CALL getin('VEGETATION_FILE',filename)
+    !
+    CALL flininfo(filename, iml, jml, lml, tml, fid)
+    !
+    !
+    ALLOCATE(lat_ful(iml))
+    ALLOCATE(lon_ful(iml))
+    ALLOCATE(vegmap(iml))
+    !
+    WRITE(numout,*) 'Reading the vegetation file'
+    !
+    CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
+    CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
+    CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
+    !
+    CALL flinclo(fid)
+    
+    !
+    IF (MAXVAL(vegmap) .LT. nolson) THEN
+      WRITE(*,*) 'WARNING -- WARNING'
+      WRITE(*,*) 'The vegetation map has to few vegetation types.'
+      WRITE(*,*) 'If you are lucky it will work but please check'
+    ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
+      WRITE(*,*) 'More vegetation types in file than the code can'
+      WRITE(*,*) 'deal with.: ',  MAXVAL(vegmap),  nolson
+      STOP 'slowproc_interpol'
+    ENDIF
+    !
+    ALLOCATE(lon_up(nbpt)) 
+    ALLOCATE(lon_low(nbpt))
+    ALLOCATE(lat_up(nbpt))
+    ALLOCATE(lat_low(nbpt))
+    !
+    DO ib =1, nbpt
+       !
+       !  We find the 4 limits of the grid-box. As we transform the resolution of the model
+       !  into longitudes and latitudes we do not have the problem of periodicity.
+       !  coslat is a help variable here !
+       !
+       coslat = MAX(COS(lalo(ib,1) * pi/180. ), 0.001 )*pi/180. * R_Earth
+       !
+       lon_up(ib) = lalo(ib,2) + resolution(ib,1)/(2.0*coslat) 
+       lon_low(ib) = lalo(ib,2) - resolution(ib,1)/(2.0*coslat) 
+       !
+       coslat = pi/180. * R_Earth
+       !
+       lat_up(ib) = lalo(ib,1) + resolution(ib,2)/(2.0*coslat) 
+       lat_low(ib) = lalo(ib,1) - resolution(ib,2)/(2.0*coslat) 
+       !
+       !
+       veget(ib,:) = zero
+       frac_nobio (ib,:) = zero
+       !
+    ENDDO
+    !
+    !  Get the limits of the integration domaine so that we can speed up the calculations
+    !
+    domaine_lon_min = MINVAL(lon_low)
+    domaine_lon_max = MAXVAL(lon_up)
+    domaine_lat_min = MINVAL(lat_low)
+    domaine_lat_max = MAXVAL(lat_up)
+    !
+!!$    WRITE(*,*) 'DOMAINE lon :', domaine_lon_min, domaine_lon_max
+!!$    WRITE(*,*) 'DOMAINE lat :', domaine_lat_min, domaine_lat_max
+    !
+    ! Ensure that the fine grid covers the whole domain
+    WHERE ( lon_ful(:) .LT. domaine_lon_min )
+      lon_ful(:) = lon_ful(:) + 360.
+    ENDWHERE
+    !
+    WHERE ( lon_ful(:) .GT. domaine_lon_max )
+      lon_ful(:) = lon_ful(:) - 360.
+    ENDWHERE
+    !
+    WRITE(numout,*) 'Interpolating the vegetation map :'
+    WRITE(numout,'(2a40)')'0%--------------------------------------', &
+                   & '------------------------------------100%'
+    !
+    ilast = 1
+    n_origveg(:,:) = 0
+    !
+    DO ip=1,iml
+      !
+      !   Give a progress meter
+      !
+      ! prog = ip/float(iml)*79.
+      !  IF ( ABS(prog - NINT(prog)) .LT. 1/float(iml)*79. ) THEN
+      !   meter(NINT(prog)+1:NINT(prog)+1) = 'x'
+      !   WRITE(numout, advance="no", FMT='(a)') ACHAR(13)
+      !   WRITE(numout, advance="no", FMT='(a80)') meter
+      ! ENDIF
+      iprog = NINT(float(ip)/float(iml)*79.) - NINT(float(ip-1)/float(iml)*79.)
+      IF ( iprog .NE. 0 ) THEN
+        WRITE(numout,'(a1,$)') 'x'
+      ENDIF
+      !
+      !  Only start looking for its place in the smaler grid if we are within the domaine
+      !  That should speed up things !
+      !
+      IF ( ( lon_ful(ip) .GE. domaine_lon_min ) .AND. &
+           ( lon_ful(ip) .LE. domaine_lon_max ) .AND. &
+           ( lat_ful(ip) .GE. domaine_lat_min ) .AND. &
+           ( lat_ful(ip) .LE. domaine_lat_max )        ) THEN
+        !
+        ! look for point on GCM grid which this point on fine grid belongs to.
+        ! First look at the point on the model grid where we arrived just before. There is 
+        ! a good chace that neighbouring points on the fine grid fall into the same model
+        ! grid box.
+        !
+        !
+        ! THERE IS A BUG HERE !!! IF THE GCM GRID SITS ON THE DATE LINE WE WILL HAVE FOR INSTANCE
+        ! LON_LOW = -182 AND LON_UP = -178. THUS WE WILL ONLY PICK UP HALF THE POINTS NEEDED.
+        !
+        IF ( ( lon_ful(ip) .GT. lon_low(ilast) ) .AND. &
+             ( lon_ful(ip) .LT. lon_up(ilast) ) .AND. &
+             ( lat_ful(ip) .GT. lat_low(ilast) ) .AND. &
+             ( lat_ful(ip) .LT. lat_up(ilast) )         ) THEN
+          !
+          ! We were lucky
+          !
+          n_origveg(ilast,NINT(vegmap(ip))) = n_origveg(ilast,NINT(vegmap(ip))) + 1
+          !
+        ELSE
+          !
+          ! Otherwise, look everywhere.
+          ! Begin close to last grid point.
+          !
+          found = .FALSE. 
+          idi = 1
+          !
+          DO WHILE ( (idi .LT. nbpt) .AND. ( .NOT. found ) )
+            !
+            ! forward and backward
+            !
+            DO ii = 1,2
+              !
+              IF ( ii .EQ. 1 ) THEN
+                ib = ilast - idi
+              ELSE
+                ib = ilast + idi
+              ENDIF
+              !
+              IF ( ( ib .GE. 1 ) .AND. ( ib .LE. nbpt ) ) THEN
+                IF ( ( lon_ful(ip) .GT. lon_low(ib) ) .AND. &
+                     ( lon_ful(ip) .LT. lon_up(ib) ) .AND. &
+                     ( lat_ful(ip) .GT. lat_low(ib) ) .AND. &
+                     ( lat_ful(ip) .LT. lat_up(ib) )         ) THEN
+                  !
+                  n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + 1
+                  ilast = ib
+                  found = .TRUE.
+                  !
+                ENDIF
+              ENDIF
+              !
+            ENDDO
+            !
+            idi = idi + 1
+            !
+          ENDDO
+          !
+        ENDIF ! lucky/not lucky
+        !
+      ENDIF     ! in the domain
+    ENDDO
+
+    !
+    ! Now we know how many points of which Olson type from the fine grid fall
+    ! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
+    !
+
+    !
+    ! determine number of points of the fine grid which fall into each box of the 
+    ! coarse grid
+    !
+    DO ib = 1, nbpt
+      n_found(ib) = SUM( n_origveg(ib,:) )
+    ENDDO
+
+    !
+    ! determine fraction of Olson vegetation type in each box of the coarse grid
+    !
+    DO vid = 1, nolson
+      WHERE ( n_found(:) .GT. 0 ) 
+        frac_origveg(:,vid) =  REAL(n_origveg(:,vid),r_std) /  REAL(n_found(:),r_std)
+      ELSEWHERE
+         frac_origveg(:,vid) = zero
+      ENDWHERE
+    ENDDO
+
+    !
+    ! now finally calculate coarse vegetation map
+    ! Find which model vegetation corresponds to each Olson type 
+    !
+    DO vid = 1, nolson
+      !
+      DO jv = 1, nvm
+        veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
+      ENDDO
+      !
+      DO jv = 1, nnobio
+        frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
+      ENDDO
+      !
+    ENDDO
+    !
+    !
+    WRITE(numout,*)
+    WRITE(numout,*) 'Interpolation Done'
+    !
+    !   Clean up the point of the map
+    !
+    DO ib = 1, nbpt
+       !
+       !  Let us see if all points found something in the 5km map !
+       !
+       IF ( n_found(ib) .EQ. 0 ) THEN
+          !
+          ! Now we need to handle some exceptions
+          !
+          IF ( lalo(ib,1) .LT. -56.0) THEN
+             ! Antartica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
+             ! Artica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
+             ! Greenland
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE
+             !
+             WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box'
+             WRITE(numout,*) 'Longitude range : ', lon_low(ib), lon_up(ib)
+             WRITE(numout,*) 'Latitude range : ', lat_low(ib), lat_up(ib)
+             !
+             WRITE(numout,*) 'Looking for nearest point on the 5 km map'
+             CALL slowproc_nearest (iml, lon_ful, lat_ful, &
+                                    lalo(ib,2), lalo(ib,1), inear)
+             WRITE(numout,*) 'Coordinates of the nearest point:', &
+                              lon_ful(inear),lat_ful(inear)
+             !
+             DO jv = 1, nvm
+               veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+             DO jv = 1, nnobio
+               frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+          ENDIF
+          !
+       ENDIF
+       !
+       !
+       !  Limit the smalest vegetation fraction to 0.5%
+       !
+       DO vid = 1, nvm
+          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
+             veget(ib,vid) = zero
+          ENDIF
+       ENDDO
+       !
+       sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
+       frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
+       veget(ib,:) = veget(ib,:)/sumf
+       !
+       !       
+    ENDDO
+    !
+    DEALLOCATE(lon_up)
+    DEALLOCATE(lon_low)
+    DEALLOCATE(lat_up)
+    DEALLOCATE(lat_low)
+    DEALLOCATE(lat_ful)
+    DEALLOCATE(lon_ful)
+    DEALLOCATE(vegmap)
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_interpol_OLD_g
+  !!
+  !! Interpolate the IGBP vegetation map to the grid of the model
+  !!
+  SUBROUTINE slowproc_interpol_NEW_g(nbpt, lalo, neighbours, resolution, contfrac, veget, frac_nobio )
+    !
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)          :: nbpt                  ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)              :: lalo(nbpt,2)          ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)          :: neighbours(nbpt,8)    ! Vector of neighbours for each grid point 
+    ! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    REAL(r_std), INTENT(in)              :: resolution(nbpt,2)    ! The size in km of each grid-box in X and Y
+    REAL(r_std),DIMENSION (nbpt), INTENT (in) :: contfrac         !! Fraction of continent in the grid
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)    ::  veget(nbpt,nvm)         ! Vegetation fractions
+    REAL(r_std), INTENT(out)    ::  frac_nobio(nbpt,nnobio) ! Fraction of the mesh which is covered by ice, lakes, ...
+    !
+    LOGICAL ::           ok_interpol  ! optionnal return of aggregate_vec
+    !
+    !  0.3 LOCAL
+    !
+    INTEGER(i_std), PARAMETER                       :: nolson = 94  ! Number of Olson classes
+    !
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, vid
+    REAL(r_std), ALLOCATABLE, DIMENSION(:) :: lat_ful, lon_ful, vegmap
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: sub_area
+    INTEGER(i_std),ALLOCATABLE, DIMENSION(:,:) :: sub_index
+    REAL(r_std), DIMENSION(nbpt,nolson) :: n_origveg
+    REAL(r_std), DIMENSION(nbpt) :: n_found
+    REAL(r_std), DIMENSION(nbpt,nolson) :: frac_origveg
+    REAL(r_std) :: vegcorr(nolson,nvm)
+    REAL(r_std) :: nobiocorr(nolson,nnobio)
+    CHARACTER(LEN=40) :: callsign
+    REAL(r_std) :: sumf, resol_lon, resol_lat
+    INTEGER(i_std) :: idi, jv, inear, nbvmax
+    !
+    INTEGER                  :: ALLOC_ERR
+    !
+    n_origveg(:,:) = zero
+    n_found(:) = zero
+    !
+    CALL get_vegcorr (nolson,vegcorr,nobiocorr)
+    !
+    !Config Key  = VEGETATION_FILE
+    !Config Desc = Name of file from which the vegetation map is to be read
+    !Config If   = !IMPOSE_VEG
+    !Config If   = !LAND_USE
+    !Config Def  = ../surfmap/carteveg5km.nc
+    !Config Help = The name of the file to be opened to read the vegetation
+    !Config        map is to be given here. Usualy SECHIBA runs with a 5kmx5km
+    !Config        map which is derived from the IGBP one. We assume that we have
+    !Config        a classification in 87 types. This is Olson modified by Viovy.
+    !
+    filename = '../surfmap/carteveg5km.nc'
+    CALL getin('VEGETATION_FILE',filename)
+    !
+    CALL flininfo(filename, iml, jml, lml, tml, fid)
+    !
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(lat_ful(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(lon_ful(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon_ful : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(vegmap(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of vegmap : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    WRITE(numout,*) 'Reading the OLSON type vegetation file'
+    !
+    CALL flinget(fid, 'longitude', iml, jml, lml, tml, 1, 1, lon_ful)
+    CALL flinget(fid, 'latitude', iml, jml, lml, tml, 1, 1, lat_ful)
+    CALL flinget(fid, 'vegetation_map', iml, jml, lml, tml, 1, 1, vegmap)
+    !
+    CALL flinclo(fid)
+    !
+    IF (MAXVAL(vegmap) .LT. nolson) THEN
+       WRITE(numout,*) 'WARNING -- WARNING'
+       WRITE(numout,*) 'The vegetation map has to few vegetation types.'
+       WRITE(numout,*) 'If you are lucky it will work but please check'
+    ELSE IF ( MAXVAL(vegmap) .GT. nolson) THEN
+       WRITE(numout,*) 'More vegetation types in file than the code can'
+       WRITE(numout,*) 'deal with.: ',  MAXVAL(vegmap),  nolson
+       STOP 'slowproc_interpol'
+    ENDIF
+    !
+    ! Some assumptions on the vegetation file. This information should be
+    ! be computed or read from the file. 
+    ! It is the reolution in meters of the grid of the vegetation file.
+    !
+    resol_lon = 5000.
+    resol_lat = 5000.
+    !
+    ! The number of maximum vegetation map points in the GCM grid should
+    ! also be computed and not imposed here.
+    nbvmax = iml/nbpt
+    !
+    callsign="Vegetation map"
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+       WRITE(numout,*) "nbvmax = ",nbvmax
+       !
+       ALLOC_ERR=-1
+       ALLOCATE(sub_index(nbpt, nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_index(:,:)=0
+       ALLOC_ERR=-1
+       ALLOCATE(sub_area(nbpt, nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_area(:,:)=zero
+       !
+       CALL aggregate (nbpt, lalo, neighbours, resolution, contfrac, &
+            &                iml, lon_ful, lat_ful, resol_lon, resol_lat, callsign, &
+            &                nbvmax, sub_index, sub_area, ok_interpol)
+       !
+       IF ( .NOT. ok_interpol ) THEN
+          DEALLOCATE(sub_area)
+          DEALLOCATE(sub_index)
+          !
+          nbvmax = nbvmax * 2
+       ELSE
+          !
+          DO ib = 1, nbpt
+             idi=1
+             DO WHILE ( sub_area(ib,idi) > zero ) 
+                ip = sub_index(ib,idi)
+                n_origveg(ib,NINT(vegmap(ip))) = n_origveg(ib,NINT(vegmap(ip))) + sub_area(ib,idi)
+                n_found(ib) =  n_found(ib) + sub_area(ib,idi)
+                idi = idi +1
+             ENDDO
+          ENDDO
+          !
+       ENDIF
+    ENDDO
+    !
+    ! Now we know how many points of which Olson type from the fine grid fall
+    ! into each box of the (coarse) model grid: n_origveg(nbpt,nolson)
+    !
+    !
+    ! determine fraction of Olson vegetation type in each box of the coarse grid
+    !
+    DO vid = 1, nolson
+       WHERE ( n_found(:) .GT. 0 ) 
+          frac_origveg(:,vid) = n_origveg(:,vid) / n_found(:)
+       ELSEWHERE
+          frac_origveg(:,vid) = zero
+       ENDWHERE
+    ENDDO
+    !
+    ! now finally calculate coarse vegetation map
+    ! Find which model vegetation corresponds to each Olson type 
+    !
+    veget(:,:) = zero
+    frac_nobio(:,:) = zero
+    !
+    DO vid = 1, nolson
+       !
+       DO jv = 1, nvm
+          veget(:,jv) = veget(:,jv) + frac_origveg(:,vid) * vegcorr(vid,jv)
+       ENDDO
+       !
+       DO jv = 1, nnobio
+          frac_nobio(:,jv) = frac_nobio(:,jv) + frac_origveg(:,vid) * nobiocorr(vid,jv)
+       ENDDO
+       !
+    ENDDO
+    !
+    WRITE(numout,*) 'slowproc_interpol : Interpolation Done'
+    !
+    !   Clean up the point of the map
+    !
+    DO ib = 1, nbpt
+       !
+       !  Let us see if all points found something in the 5km map !
+       !
+       IF ( n_found(ib) .EQ. 0 ) THEN
+          !
+          ! Now we need to handle some exceptions
+          !
+          IF ( lalo(ib,1) .LT. -56.0) THEN
+             ! Antartica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 70.0) THEN
+             ! Artica
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE IF ( lalo(ib,1) .GT. 55.0 .AND. lalo(ib,2) .GT. -65.0 .AND. lalo(ib,2) .LT. -20.0) THEN
+             ! Greenland
+             frac_nobio(ib,:) = zero
+             frac_nobio(ib,iice) = un
+             veget(ib,:) = zero
+             !
+          ELSE
+             !
+             WRITE(numout,*) 'PROBLEM, no point in the 5km map found for this grid box',ib
+             WRITE(numout,*) 'Longitude range : ', lalo(ib,2)
+             WRITE(numout,*) 'Latitude range : ', lalo(ib,1)
+             !
+             WRITE(numout,*) 'Looking for nearest point on the 5 km map'
+             CALL slowproc_nearest (iml, lon_ful, lat_ful, &
+                  lalo(ib,2), lalo(ib,1), inear)
+             WRITE(numout,*) 'Coordinates of the nearest point:', &
+                  lon_ful(inear),lat_ful(inear)
+             !
+             DO jv = 1, nvm
+                veget(ib,jv) = vegcorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+             DO jv = 1, nnobio
+                frac_nobio(ib,jv) = nobiocorr(NINT(vegmap(inear)),jv)
+             ENDDO
+             !
+          ENDIF
+          !
+       ENDIF
+       !
+       !
+       !  Limit the smalest vegetation fraction to 0.5%
+       !
+       DO vid = 1, nvm
+          IF ( veget(ib,vid) .LT. min_vegfrac ) THEN
+             veget(ib,vid) = zero
+          ENDIF
+       ENDDO
+       !
+       sumf = SUM(frac_nobio(ib,:))+SUM(veget(ib,:))
+       frac_nobio(ib,:) = frac_nobio(ib,:)/sumf
+       veget(ib,:) = veget(ib,:)/sumf
+       !
+       !       
+    ENDDO
+    !
+    DEALLOCATE(vegmap)
+    DEALLOCATE(lat_ful, lon_ful)
+    DEALLOCATE(sub_index)
+    DEALLOCATE(sub_area)
+
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_interpol_NEW_g
+
+
+  !!
+  !! looks for nearest grid point on the fine map
+  !!
+  SUBROUTINE slowproc_nearest(iml, lon5, lat5, lonmod, latmod, inear)
+
+    INTEGER(i_std), INTENT(in)                   :: iml
+    REAL(r_std), DIMENSION(iml), INTENT(in)      :: lon5, lat5
+    REAL(r_std), INTENT(in)                      :: lonmod, latmod
+
+    INTEGER(i_std), INTENT(out)                  :: inear
+
+    REAL(r_std)                                  :: pi
+    REAL(r_std)                                  :: pa, p
+    REAL(r_std)                                  :: coscolat, sincolat
+    REAL(r_std)                                  :: cospa, sinpa
+    REAL(r_std), ALLOCATABLE, DIMENSION(:)       :: cosang
+    INTEGER(i_std)                               :: i
+    INTEGER(i_std), DIMENSION(1)                 :: ineartab
+    INTEGER                  :: ALLOC_ERR
+
+    ALLOC_ERR=-1
+    ALLOCATE(cosang(iml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of cosang : ",ALLOC_ERR
+      STOP 
+    ENDIF
+
+    pi = 4.0 * ATAN(1.0)
+
+    pa = pi/2.0 - latmod*pi/180.0 ! dist. entre pole n et point a
+    cospa = COS(pa)
+    sinpa = SIN(pa)
+
+    DO i = 1, iml
+
+       sincolat = SIN( pi/2.0 - lat5(i)*pi/180.0 ) 
+       coscolat = COS( pi/2.0 - lat5(i)*pi/180.0 ) 
+
+       p = (lonmod-lon5(i))*pi/180.0 ! angle entre a et b (leurs meridiens)
+
+       ! dist(i) = ACOS( cospa*coscolat + sinpa*sincolat*COS(p))
+       cosang(i) = cospa*coscolat + sinpa*sincolat*COS(p)
+
+    ENDDO
+
+    ineartab = MAXLOC( cosang(:) )
+    inear = ineartab(1)
+
+    DEALLOCATE(cosang)
+  END SUBROUTINE slowproc_nearest
+
+  !!
+  !! Interpolate the Zobler soil type map
+  !!
+  SUBROUTINE slowproc_soilt(nbpt, lalo, neighbours, resolution, contfrac, soiltype, clayfraction)
+    !
+    !
+    !   This subroutine should read the Zobler map and interpolate to the model grid. The method
+    !   is to get fraction of the three main soiltypes for each grid box.
+    !   The soil fraction are going to be put into the array soiltype in the following order :
+    !   coarse, medium and fine.
+    !
+    !
+    !  0.1 INPUT
+    !
+    INTEGER(i_std), INTENT(in)    :: nbpt                   ! Number of points for which the data needs to be interpolated
+    REAL(r_std), INTENT(in)       :: lalo(nbpt,2)           ! Vector of latitude and longitudes (beware of the order !)
+    INTEGER(i_std), INTENT(in)    :: neighbours(nbpt,8)     ! Vector of neighbours for each grid point 
+    ! (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    REAL(r_std), INTENT(in)       :: resolution(nbpt,2)     ! The size in km of each grid-box in X and Y
+    REAL(r_std), INTENT(in)       :: contfrac(nbpt)     ! Fraction of land in each grid box.
+    !
+    !  0.2 OUTPUT
+    !
+    REAL(r_std), INTENT(out)      :: soiltype(nbpt, nstm) ! Soil type map to be created from the Zobler map
+    REAL(r_std), INTENT(out)      :: clayfraction(nbpt)     ! The fraction of clay as used by STOMATE
+    !
+    !
+    !  0.3 LOCAL
+    !
+    INTEGER(i_std)               :: nbvmax
+    !
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: iml, jml, lml, tml, fid, ib, ip, jp, fopt, ilf, nbexp
+    REAL(r_std) :: lev(1), date, dt
+    INTEGER(i_std) :: itau(1)
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:) :: lat_rel, lon_rel, soiltext
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:) :: mask
+    REAL(r_std), ALLOCATABLE, DIMENSION(:,:)  :: sub_area
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:,:)  :: sub_index
+    INTEGER(i_std), ALLOCATABLE, DIMENSION(:) :: solt
+    REAL(r_std) ::  sgn
+    CHARACTER(LEN=30) :: callsign
+    !
+    ! Number of texture classes in Zobler
+    !
+    INTEGER(i_std), PARAMETER :: classnb = 7
+    REAL(r_std)               :: textfrac_table(classnb, nstm)
+    !   
+    LOGICAL                  :: ok_interpol  ! optionnal return of aggregate_2d
+    !   
+    INTEGER                  :: ALLOC_ERR
+    !
+    !
+    CALL get_soilcorr (classnb, textfrac_table)
+    !
+    !  Needs to be a configurable variable
+    !
+    !
+    !Config Key  = SOILTYPE_FILE
+    !Config Desc = Name of file from which soil types are read
+    !Config Def  = ../surfmap/soils_param.nc
+    !Config If   = !IMPOSE_VEG
+    !Config Help = The name of the file to be opened to read the soil types. 
+    !Config        The data from this file is then interpolated to the grid of
+    !Config        of the model. The aim is to get fractions for sand loam and
+    !Config        clay in each grid box. This information is used for soil hydrology
+    !Config        and respiration.
+    !
+    filename = '../surfmap/soils_param.nc'
+    CALL getin_p('SOILTYPE_FILE',filename)
+    !
+    IF (is_root_prc) THEN
+       CALL flininfo(filename,iml, jml, lml, tml, fid)
+       CALL flinclo(fid)
+    ENDIF
+    CALL bcast(iml)
+    CALL bcast(jml)
+    CALL bcast(lml)
+    CALL bcast(tml)
+    !
+    ! soils_param.nc file is 1° soit texture file.
+    !
+    ALLOC_ERR=-1
+    ALLOCATE(lat_rel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lat_rel : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(lon_rel(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of lon_rel : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(mask(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of mask : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    ALLOC_ERR=-1
+    ALLOCATE(soiltext(iml,jml), STAT=ALLOC_ERR)
+    IF (ALLOC_ERR/=0) THEN
+      WRITE(numout,*) "ERROR IN ALLOCATION of soiltext : ",ALLOC_ERR
+      STOP 
+    ENDIF
+    !
+    IF (is_root_prc) CALL flinopen(filename, .FALSE., iml, jml, lml, lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
+    CALL bcast(lon_rel)
+    CALL bcast(lat_rel)
+    CALL bcast(itau)
+    CALL bcast(date)
+    CALL bcast(dt)
+    
+    !
+    IF (is_root_prc) CALL flinget(fid, 'soiltext', iml, jml, lml, tml, 1, 1, soiltext)
+    CALL bcast(soiltext)
+    !
+    IF (is_root_prc) CALL flinclo(fid)
+    !
+    nbexp = 0
+    !
+    !
+    ! Mask of permitted variables.
+    !
+    mask(:,:) = zero
+    DO ip=1,iml
+       DO jp=1,jml
+          IF (soiltext(ip,jp) .GT. min_sechiba) THEN
+             mask(ip,jp) = un
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    nbvmax = 200
+    !
+    callsign = "Soil types"
+    !
+    ok_interpol = .FALSE.
+    DO WHILE ( .NOT. ok_interpol )
+       WRITE(numout,*) "Projection arrays for ",callsign," : "
+       WRITE(numout,*) "nbvmax = ",nbvmax
+       !
+       ALLOC_ERR=-1
+       ALLOCATE(solt(nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of solt : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       ALLOC_ERR=-1
+       ALLOCATE(sub_index(nbpt,nbvmax,2), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_index : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_index(:,:,:)=0
+       ALLOC_ERR=-1
+       ALLOCATE(sub_area(nbpt,nbvmax), STAT=ALLOC_ERR)
+       IF (ALLOC_ERR/=0) THEN
+          WRITE(numout,*) "ERROR IN ALLOCATION of sub_area : ",ALLOC_ERR
+          STOP 
+       ENDIF
+       sub_area(:,:)=zero
+       !
+       CALL aggregate_p(nbpt, lalo, neighbours, resolution, contfrac, &
+            &                iml, jml, lon_rel, lat_rel, mask, callsign, &
+            &                nbvmax, sub_index, sub_area, ok_interpol)
+       !
+       IF ( .NOT. ok_interpol ) THEN
+          DEALLOCATE(sub_area)
+          DEALLOCATE(sub_index)
+          DEALLOCATE(solt)
+          !
+          nbvmax = nbvmax * 2
+       ENDIF
+    ENDDO
+    !
+    DO ib =1, nbpt
+       !
+       soiltype(ib,:) = zero
+       clayfraction(ib) = zero
+       !
+       ! GO through the point we have found
+       !
+       !
+       fopt = COUNT(sub_area(ib,:) > zero)
+       !
+       !    Check that we found some points
+       !
+       IF ( fopt .EQ. 0) THEN
+          nbexp = nbexp + 1
+          soiltype(ib,:) = soiltype_default(:)
+          clayfraction(ib) = clayfraction_default
+       ELSE
+          !
+          DO ilf = 1,fopt
+             solt(ilf) = soiltext(sub_index(ib,ilf,1),sub_index(ib,ilf,2))
+          ENDDO
+          !
+          sgn = zero
+          !
+          !   Compute the average bare soil albedo parameters
+          !
+          DO ilf = 1,fopt
+             !
+             ! We have to take care of two exceptions here : type 6 = glacier and type 0 = ocean
+             !
+             IF ( (solt(ilf) .LE. classnb) .AND. (solt(ilf) .GT. 0) .AND.&
+                  & (solt(ilf) .NE. 6)) THEN
+                SELECTCASE(solt(ilf))
+                CASE(1)
+                   soiltype(ib,1) = soiltype(ib,1) + sub_area(ib,ilf)
+                CASE(2)
+                   soiltype(ib,2) = soiltype(ib,2) + sub_area(ib,ilf)
+                CASE(3)
+                   soiltype(ib,2) = soiltype(ib,2) + sub_area(ib,ilf)
+                CASE(4)
+                   soiltype(ib,2) = soiltype(ib,2) + sub_area(ib,ilf)
+                CASE(5)
+                   soiltype(ib,3) = soiltype(ib,3) + sub_area(ib,ilf)
+                CASE(7)
+                   soiltype(ib,2) = soiltype(ib,2) + sub_area(ib,ilf)
+                CASE DEFAULT
+                   WRITE(numout,*) 'We should not be here, an impossible case appeared'
+                   STOP 'slowproc_soilt'
+                END SELECT
+                clayfraction(ib) = clayfraction(ib) + &
+                     & textfrac_table(solt(ilf),3) * sub_area(ib,ilf)
+                sgn = sgn + sub_area(ib,ilf)
+             ELSE
+                IF (solt(ilf) .GT. classnb) THEN
+                   WRITE(numout,*) 'The file contains a soil color class which is incompatible with this program'
+                   STOP 'slowproc_soilt'
+                ENDIF
+             ENDIF
+             !
+          ENDDO
+          !
+          ! Normalize the surface
+          !
+          IF ( sgn .LT. min_sechiba) THEN
+             nbexp = nbexp + 1
+             soiltype(ib,:) = soiltype_default(:)
+             clayfraction(ib) = clayfraction_default
+          ELSE
+             soiltype(ib,:) = soiltype(ib,:)/sgn
+             clayfraction(ib) = clayfraction(ib)/sgn
+          ENDIF
+          !
+       ENDIF
+       !
+    ENDDO
+    !
+    IF ( nbexp .GT. 0 ) THEN
+       WRITE(numout,*) 'slowproc_soilt : The interpolation of the bare soil albedo had ', nbexp
+       WRITE(numout,*) 'slowproc_soilt : points without data. This are either coastal points or'
+       WRITE(numout,*) 'slowproc_soilt : ice covered land.'
+       WRITE(numout,*) 'slowproc_soilt : The problem was solved by using the default soil types.'
+    ENDIF
+    !
+    DEALLOCATE (lat_rel)
+    DEALLOCATE (lon_rel)
+    DEALLOCATE (mask)
+    DEALLOCATE (sub_area)
+    DEALLOCATE (sub_index)
+    DEALLOCATE (soiltext)
+    DEALLOCATE (solt)
+    !
+    !
+    RETURN
+    !
+  END SUBROUTINE slowproc_soilt
+    !
+
+
+END MODULE slowproc
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/thermosoil.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/thermosoil.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/thermosoil.f90	(revision 55)
@@ -0,0 +1,1009 @@
+!!
+!! This module computes soil thermodynamic
+!!
+!! @author Marie-Alice Foujols and Jan Polcher
+!! @Version : $Revision$, $Date$
+!! 
+!< $HeadURL$
+!< $Date$
+!< $Author$
+!< $Revision$
+!! IPSL (2006)
+!!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!!
+MODULE thermosoil
+
+  ! routines called : restput, restget
+  !
+  USE ioipsl
+  !
+  ! modules used :
+  USE constantes
+  USE constantes_soil
+  USE sechiba_io
+  USE grid
+  USE parallel
+
+  IMPLICIT NONE
+
+  ! public routines :
+  ! thermosoil_main
+  PRIVATE
+  PUBLIC :: thermosoil_main,thermosoil_clear 
+
+  !
+  ! variables used inside thermosoil module : declaration and initialisation
+  !
+  LOGICAL, SAVE                             :: l_first_thermosoil=.TRUE. !! Initialisation has to be done one time
+
+  CHARACTER(LEN=80) , SAVE                  :: var_name                  !! To store variables names for I/O
+  REAL(r_std), SAVE                          :: lambda, cstgrnd, lskin, fz1, zalph
+
+  ! two dimensions array allocated, computed, saved and got in thermosoil module
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: ptn               !! Different levels soil temperature
+
+  ! one dimension array allocated, computed and used in thermosoil module exclusively
+
+  REAL(r_std), SAVE, DIMENSION (ngrnd)             :: zz                !!
+  REAL(r_std), SAVE, DIMENSION (ngrnd)             :: zz_coef
+  REAL(r_std), SAVE, DIMENSION (ngrnd)             :: dz1               !!
+  REAL(r_std), SAVE, DIMENSION (ngrnd)             :: dz2               !!
+
+  ! one dimension array allocated, computed and used in thermosoil module exclusively
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: z1                !!
+
+  ! two dimensions arrays allocated, computed and used in thermosoil module exclusively
+
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: cgrnd             !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: dgrnd             !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: pcapa             !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: pkappa            !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: zdz1              !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: zdz2              !!
+  !
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: pcapa_en          !! Capacity used for energy_incr calculation
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: ptn_beg           !! Temperature at the beginning of the time step 
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: temp_sol_beg      !! Surface temperature at the beginning of the timestep
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: surfheat_incr     !! Change in soil heat
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:)    :: coldcont_incr     !! Change in snow cold content 
+  !!
+  REAL(r_std), ALLOCATABLE, SAVE, DIMENSION (:,:)  :: wetdiag           !! Soil weetness on the thermodynamical levels
+  !!
+CONTAINS
+
+  !! Main routine for *thermosoil* module.
+  !!
+  !! Algorithm:
+  !! - call thermosoil_var_init to initialise variables
+  !! - call thermosoil_coef for coefficient
+  !! - call thermosoil_profile for soil profiling
+  !! 
+  !! @call thermosoil_var_init
+  !! @call thermosoil_coef
+  !! @call thermosoil_profile
+  !! 
+  SUBROUTINE thermosoil_main (kjit, kjpindex, dtradia, ldrestart_read, ldrestart_write, index, indexgrnd, &
+       & temp_sol_new, snow, soilcap, soilflx, shumdiag, stempdiag, rest_id, hist_id, hist2_id)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                         :: kjit             !! Time step number 
+    INTEGER(i_std), INTENT(in)                         :: kjpindex         !! Domain size
+    INTEGER(i_std),INTENT (in)                         :: rest_id,hist_id  !! _Restart_ file and history file identifier
+    INTEGER(i_std),INTENT (in)                         :: hist2_id         !! history file 2 identifier
+    REAL(r_std), INTENT (in)                           :: dtradia          !! Time step in seconds
+    LOGICAL, INTENT(in)                               :: ldrestart_read   !! Logical for _restart_ file to read
+    LOGICAL, INTENT(in)                               :: ldrestart_write  !! Logical for _restart_ file to write
+    ! input fields
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)       :: index            !! Indeces of the points on the map
+    INTEGER(i_std),DIMENSION (kjpindex*ngrnd), INTENT (in) :: indexgrnd        !! Indeces of the points on the 3D map
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: temp_sol_new     !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)      :: snow             !! Snow quantity
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in) :: shumdiag         !! Diagnostic of relative humidity
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: soilcap          !! Soil capacity
+    REAL(r_std),DIMENSION (kjpindex), INTENT (inout)   :: soilflx          
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (inout):: stempdiag        !! diagnostic temp profile
+
+    REAL(r_std),DIMENSION (kjpindex,ngrnd) :: temp
+    REAL(r_std),DIMENSION (kjpindex,ngrnd-1) :: temp1
+    REAL(r_std),DIMENSION (kjpindex) :: temp2
+    !
+    ! do initialisation
+    !
+    IF (l_first_thermosoil) THEN
+
+        IF (long_print) WRITE (numout,*) ' l_first_thermosoil : call thermosoil_init '
+
+        !
+        ! do needed allocation 
+        !
+        CALL thermosoil_init (kjit, ldrestart_read, kjpindex, index, rest_id)
+
+        !
+        ! computes some physical constantes and array depending soil level depth
+        !
+        CALL thermosoil_var_init (kjpindex, zz, zz_coef, dz1, dz2, pkappa, pcapa, pcapa_en, shumdiag, stempdiag)
+
+        !
+        ! computes cgrd and dgrd coefficient from previous time step (restart)
+        !
+        CALL thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
+           & zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
+
+        CALL thermosoil_energy (kjpindex, temp_sol_new, soilcap, .TRUE.)
+
+        IF (ldrestart_read) THEN
+           IF (long_print) WRITE (numout,*) ' we have to READ a restart file for THERMOSOIL variables'
+
+           var_name= 'cgrnd'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','Cgrnd coefficient.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, ngrnd-1, 1, kjit, .TRUE., temp1, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp1) < MAXVAL(temp1) .OR. MAXVAL(temp1) .NE. val_exp) THEN
+                 cgrnd(:,:)=temp1(:,:)
+              ENDIF
+           ENDIF
+
+           var_name= 'dgrnd'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','Dgrnd coefficient.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, ngrnd-1, 1, kjit, .TRUE., temp1, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp1) < MAXVAL(temp1) .OR. MAXVAL(temp1) .NE. val_exp) THEN
+                 dgrnd(:,:)=temp1(:,:)
+              ENDIF
+           ENDIF
+
+           var_name= 'z1'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','?.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp2, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp2) < MAXVAL(temp2) .OR. MAXVAL(temp2) .NE. val_exp) THEN
+                 z1(:)=temp2(:)
+              ENDIF
+           ENDIF
+
+           var_name= 'pcapa'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','?.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, ngrnd, 1, kjit, .TRUE., temp, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp) < MAXVAL(temp) .OR. MAXVAL(temp) .NE. val_exp) THEN
+                 pcapa(:,:)=temp(:,:)
+              ENDIF
+           ENDIF
+
+           var_name= 'pcapa_en'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','?.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, ngrnd, 1, kjit, .TRUE., temp, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp) < MAXVAL(temp) .OR. MAXVAL(temp) .NE. val_exp) THEN
+                 pcapa_en(:,:)=temp(:,:)
+              ENDIF
+           ENDIF
+
+           var_name= 'pkappa'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','?.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, ngrnd, 1, kjit, .TRUE., temp, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp) < MAXVAL(temp) .OR. MAXVAL(temp) .NE. val_exp) THEN
+                 pkappa(:,:)=temp(:,:)
+              ENDIF
+           ENDIF
+
+           var_name= 'zdz1'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','?.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, ngrnd-1, 1, kjit, .TRUE., temp1, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp1) < MAXVAL(temp1) .OR. MAXVAL(temp1) .NE. val_exp) THEN
+                 zdz1(:,:)=temp1(:,:)
+              ENDIF
+           ENDIF
+
+           var_name= 'zdz2'
+           CALL ioconf_setatt('UNITS', '-')
+           CALL ioconf_setatt('LONG_NAME','?.')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, ngrnd, 1, kjit, .TRUE., temp, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp) < MAXVAL(temp) .OR. MAXVAL(temp) .NE. val_exp) THEN
+                 zdz2(:,:)=temp(:,:)
+              ENDIF
+           ENDIF
+
+           var_name='temp_sol_beg'
+           CALL ioconf_setatt('UNITS', 'K')
+           CALL ioconf_setatt('LONG_NAME','Old Surface temperature')
+           IF ( ok_var(var_name) ) THEN
+              CALL restget_p (rest_id, var_name, nbp_glo, 1, 1, kjit, .TRUE., temp2, "gather", nbp_glo, index_g)
+              IF (MINVAL(temp2) < MAXVAL(temp2) .OR. MAXVAL(temp2) .NE. val_exp) THEN
+                 temp_sol_beg(:) = temp2(:)
+              ENDIF
+           ENDIF
+
+        ENDIF
+
+        RETURN 
+
+    ENDIF
+
+    !
+    ! prepares restart file for the next simulation
+    !
+    IF (ldrestart_write) THEN
+
+        IF (long_print) WRITE (numout,*) ' we have to complete restart file with THERMOSOIL variables'
+
+        var_name= 'ptn'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd, 1, kjit, ptn, 'scatter', nbp_glo, index_g)
+
+        var_name= 'cgrnd'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd-1, 1, kjit, cgrnd, 'scatter', nbp_glo, index_g)
+        var_name= 'dgrnd'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd-1, 1, kjit, dgrnd, 'scatter', nbp_glo, index_g)
+
+        var_name= 'z1'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, z1, 'scatter', nbp_glo, index_g)
+
+            var_name= 'pcapa'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd, 1, kjit, pcapa, 'scatter', nbp_glo, index_g)
+
+            var_name= 'pcapa_en'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd, 1, kjit, pcapa_en, 'scatter', nbp_glo, index_g)
+
+            var_name= 'pkappa'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd, 1, kjit, pkappa, 'scatter', nbp_glo, index_g)
+
+            var_name= 'zdz1'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd-1, 1, kjit, zdz1, 'scatter', nbp_glo, index_g)
+
+            var_name= 'zdz2'
+        CALL restput_p(rest_id, var_name, nbp_glo, ngrnd, 1, kjit, zdz2, 'scatter', nbp_glo, index_g)
+
+        var_name= 'temp_sol_beg'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, temp_sol_beg, 'scatter', nbp_glo, index_g)
+
+        var_name= 'soilcap'  
+        CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  soilcap, 'scatter',  nbp_glo, index_g)
+        
+        var_name= 'soilflx'  
+        CALL restput_p(rest_id, var_name, nbp_glo,   1, 1, kjit,  soilflx, 'scatter',  nbp_glo, index_g)
+
+        ! read in enerbil
+        var_name= 'temp_sol_new'
+        CALL restput_p(rest_id, var_name, nbp_glo, 1, 1, kjit, temp_sol_new, 'scatter', nbp_glo, index_g)
+
+        RETURN 
+
+    END IF
+
+    !
+    ! Put the soil wetnesss diagnostic on the levels of the soil temprature
+    !
+    CALL thermosoil_humlev(kjpindex, shumdiag)
+
+    !
+    ! computes profile with previous cgrd and dgrd coefficient
+    !
+    CALL thermosoil_profile (kjpindex, temp_sol_new, ptn, stempdiag)
+    CALL thermosoil_energy (kjpindex, temp_sol_new, soilcap, .FALSE.)
+    !
+    IF ( .NOT. almaoutput ) THEN
+      CALL histwrite(hist_id, 'ptn', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+    ELSE
+      CALL histwrite(hist_id, 'SoilTemp', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+      CALL histwrite(hist_id, 'Qg', kjit, soilflx, kjpindex, index)
+      CALL histwrite(hist_id, 'DelSurfHeat', kjit, surfheat_incr, kjpindex, index)
+      CALL histwrite(hist_id, 'DelColdCont', kjit, coldcont_incr, kjpindex, index)
+    ENDIF
+    IF ( hist2_id > 0 ) THEN
+       IF ( .NOT. almaoutput ) THEN
+          CALL histwrite(hist2_id, 'ptn', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+       ELSE
+          CALL histwrite(hist2_id, 'SoilTemp', kjit, ptn, kjpindex*ngrnd, indexgrnd)
+          CALL histwrite(hist2_id, 'Qg', kjit, soilflx, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelSurfHeat', kjit, surfheat_incr, kjpindex, index)
+          CALL histwrite(hist2_id, 'DelColdCont', kjit, coldcont_incr, kjpindex, index)
+       ENDIF
+    ENDIF
+    !
+    ! computes cgrd and dgrd coefficient
+    !
+    CALL thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
+           & zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_main done '
+
+  END SUBROUTINE thermosoil_main
+
+  !! Initialisation for *thermosoil* module.
+  !! - does dynamic allocation for local arrays
+  !! - reads _restart_ file or set initial values to a raisonable value
+  !!
+  SUBROUTINE thermosoil_init(kjit, ldrestart_read, kjpindex, index, rest_id)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT (in)                         :: kjit               !! Time step number 
+    LOGICAL,INTENT (in)                                :: ldrestart_read     !! Logical for restart file to read
+    INTEGER(i_std), INTENT (in)                         :: kjpindex           !! Domain size
+    INTEGER(i_std),DIMENSION (kjpindex), INTENT (in)    :: index              !! Indeces of the points on the map
+
+    INTEGER(i_std), INTENT (in)                         :: rest_id            !! _Restart_ file identifier 
+    ! input fields
+    ! output fields
+
+    ! local declaration
+    INTEGER(i_std)                                     :: ier
+
+    ! initialisation
+    IF (l_first_thermosoil) THEN 
+        l_first_thermosoil=.FALSE.
+    ELSE 
+        WRITE (numout,*) ' l_first_thermosoil false . we stop '
+        STOP 'thermosoil_init'
+    ENDIF
+
+    ! two dimensions array allocation
+
+    ALLOCATE (ptn(kjpindex,ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in ptn allocation. We stop. We need ',kjpindex,' fois ',ngrnd,' words = '&
+           & , kjpindex*ngrnd
+        STOP 'thermosoil_init'
+    END IF
+
+    ! one dimension array allocation
+
+    ALLOCATE (z1(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in z1 allocation. We STOP. We need ',kjpindex,' words '
+        STOP 'thermosoil_init'
+    END IF
+
+    ! two dimension array allocation
+
+    ALLOCATE (cgrnd(kjpindex,ngrnd-1),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in cgrnd allocation. We STOP. We need ',kjpindex,' fois ',ngrnd-1 ,' words  = '&
+           & , kjpindex*(ngrnd-1)
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (dgrnd(kjpindex,ngrnd-1),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in dgrnd allocation. We STOP. We need ',kjpindex,' fois ',ngrnd-1 ,' words  = '&
+           & , kjpindex*(ngrnd-1)
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (pcapa(kjpindex,ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in pcapa allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words  = '&
+           & , kjpindex*ngrnd
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (pkappa(kjpindex,ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in pkappa allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words  = '&
+           & , kjpindex*ngrnd
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (zdz1(kjpindex,ngrnd-1),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in zdz1 allocation. We STOP. We need ',kjpindex,' fois ',ngrnd-1 ,' words  = '&
+           & , kjpindex*(ngrnd-1)
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (zdz2(kjpindex,ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in zdz2 allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words  = '&
+           & , kjpindex*ngrnd
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (surfheat_incr(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in surfheat_incr allocation. We STOP. We need ',kjpindex,' words  = '&
+           & , kjpindex
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (coldcont_incr(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in coldcont_incr allocation. We STOP. We need ',kjpindex,' words  = '&
+           & , kjpindex
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (pcapa_en(kjpindex,ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in pcapa_en allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words  = '&
+           & , kjpindex*ngrnd
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (ptn_beg(kjpindex,ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in ptn_beg allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words  = '&
+           & , kjpindex*ngrnd
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (temp_sol_beg(kjpindex),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in temp_sol_beg allocation. We STOP. We need ',kjpindex,' words  = '&
+           & , kjpindex
+        STOP 'thermosoil_init'
+    END IF
+
+    ALLOCATE (wetdiag(kjpindex,ngrnd),stat=ier)
+    IF (ier.NE.0) THEN
+        WRITE (numout,*) ' error in wetdiag allocation. We STOP. We need ',kjpindex,' fois ',ngrnd ,' words  = '&
+           & , kjpindex*ngrnd
+        STOP 'thermosoil_init'
+    END IF
+    !
+    ! open restart input file done by sechiba_init
+    ! and read data from restart input file for THERMOSOIL process
+
+    IF (ldrestart_read) THEN
+        IF (long_print) WRITE (numout,*) ' we have to READ a restart file for THERMOSOIL variables'
+
+        var_name= 'ptn'
+        CALL ioconf_setatt('UNITS', 'K')
+        CALL ioconf_setatt('LONG_NAME','Soil Temperature profile')
+        CALL restget_p (rest_id, var_name, nbp_glo, ngrnd, 1, kjit, .TRUE., ptn, "gather", nbp_glo, index_g)
+        !
+        ! change restart If they were not found in the restart file
+!
+!Config Key  = THERMOSOIL_TPRO
+!Config Desc = Initial soil temperature profile if not found in restart
+!Config Def  = 280.
+!Config Help = The initial value of the temperature profile in the soil if 
+!Config        its value is not found in the restart file. This should only 
+!Config        be used if the model is started without a restart file. Here
+!Config        we only require one value as we will assume a constant 
+!Config        throughout the column.
+!
+        CALL setvar_p (ptn, val_exp,'THERMOSOIL_TPRO',280._r_std)
+
+    ENDIF
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_init done '
+
+  END SUBROUTINE thermosoil_init
+
+  !! Function for distributing the levels
+  !!
+ SUBROUTINE thermosoil_clear()
+
+        l_first_thermosoil=.TRUE.
+ 
+        IF ( ALLOCATED (ptn)) DEALLOCATE (ptn)
+        IF ( ALLOCATED (z1)) DEALLOCATE (z1) 
+        IF ( ALLOCATED (cgrnd)) DEALLOCATE (cgrnd) 
+        IF ( ALLOCATED (dgrnd)) DEALLOCATE (dgrnd) 
+        IF ( ALLOCATED (pcapa)) DEALLOCATE (pcapa)
+        IF ( ALLOCATED (pkappa))  DEALLOCATE (pkappa)
+        IF ( ALLOCATED (zdz1)) DEALLOCATE (zdz1)
+        IF ( ALLOCATED (zdz2)) DEALLOCATE (zdz2)
+        IF ( ALLOCATED (pcapa_en)) DEALLOCATE (pcapa_en)
+        IF ( ALLOCATED (ptn_beg)) DEALLOCATE (ptn_beg)
+        IF ( ALLOCATED (temp_sol_beg)) DEALLOCATE (temp_sol_beg)
+        IF ( ALLOCATED (surfheat_incr)) DEALLOCATE (surfheat_incr)
+        IF ( ALLOCATED (coldcont_incr)) DEALLOCATE (coldcont_incr)
+        IF ( ALLOCATED (wetdiag)) DEALLOCATE (wetdiag)
+
+  END SUBROUTINE thermosoil_clear
+  !!
+  !!
+  FUNCTION fz(rk) RESULT (fz_result)
+
+    ! interface
+    ! input value
+    REAL(r_std), INTENT(in)                        :: rk
+    ! output value
+    REAL(r_std)                                    :: fz_result
+
+    fz_result = fz1 * (zalph ** rk - un) / (zalph - un)
+
+  END FUNCTION fz
+
+  !! Thermosoil's variables initialisation
+  !!
+  SUBROUTINE thermosoil_var_init(kjpindex, zz, zz_coef, dz1, dz2, pkappa, pcapa, pcapa_en, shumdiag, stempdiag)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex          !! Domain size
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (in)      :: shumdiag          !! Diagnostic humidity profile
+    ! output fields
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: zz                !!
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: zz_coef
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: dz1               !!
+    REAL(r_std), DIMENSION (ngrnd), INTENT(out)              :: dz2               !! tailles des couches
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pcapa             !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pcapa_en
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: pkappa            !!
+    REAL(r_std), DIMENSION (kjpindex,nbdl), INTENT (out)     :: stempdiag         !! Diagnostic temp profile
+
+    ! local declaration
+    INTEGER(i_std)                                :: ier, ji, jg
+    REAL(r_std)                                    :: sum
+
+    !
+    !     0. initialisation
+    !
+    cstgrnd=SQRT(one_day / pi)
+    lskin = SQRT(so_cond / so_capa * one_day / pi)
+    fz1 = 0.3_r_std * cstgrnd
+    zalph = deux
+    !
+    !     1.  Computing the depth of the Temperature level, using a
+    !         non dimentional variable x = z/lskin, lskin beeing
+    !         the skin depth
+    !
+
+    DO jg=1,ngrnd
+!!! This needs to be solved soon. Either we allow CPP options in SECHIBA or the VPP
+!!! fixes its compiler !
+!!!#ifdef VPP5000
+      dz2(jg) = fz(REAL(jg,r_std)-undemi+undemi) - fz(REAL(jg-1,r_std)-undemi+undemi)
+!!!#else
+!!!      dz2(jg) = fz(REAL(jg,r_std)) - fz(REAL(jg-1,r_std))
+!!!#endif
+    ENDDO
+    !
+    !     1.2 The undimentional depth is computed.
+    !         ------------------------------------
+    DO jg=1,ngrnd
+      zz(jg)      = fz(REAL(jg,r_std) - undemi)
+      zz_coef(jg) = fz(REAL(jg,r_std)-undemi+undemi)
+    ENDDO
+    !
+    !     1.3 Converting to meters.
+    !         --------------------
+    DO jg=1,ngrnd
+      zz(jg)      = zz(jg) /  cstgrnd * lskin
+      zz_coef(jg) = zz_coef(jg) / cstgrnd * lskin 
+      dz2(jg)     = dz2(jg) /  cstgrnd * lskin
+    ENDDO
+    !
+    !     1.4 Computing some usefull constants.
+    !         --------------------------------
+    DO jg=1,ngrnd-1
+      dz1(jg)  = un / (zz(jg+1) - zz(jg))
+    ENDDO
+    lambda = zz(1) * dz1(1)
+    !
+    !     1.5 Get the wetness profice on this grid
+    !         ------------------------------------
+    !
+    CALL thermosoil_humlev(kjpindex, shumdiag)
+    !
+    !     1.6 Thermal conductivity at all levels.
+    !         ----------------------------------
+    DO jg = 1,ngrnd
+      DO ji = 1,kjpindex
+        pkappa(ji,jg) = so_cond_dry + wetdiag(ji,jg)*(so_cond_wet - so_cond_dry)
+        pcapa(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
+        pcapa_en(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
+      ENDDO
+    ENDDO
+    !
+    !     2.  Diagnostics.
+    !         -----------
+
+    WRITE (numout,*) 'diagnostic des niveaux dans le sol'
+    WRITE (numout,*) 'niveaux intermediaires et pleins'
+    sum = zero
+    DO jg=1,ngrnd
+      sum = sum + dz2(jg)
+      WRITE (numout,*) zz(jg),sum
+    ENDDO
+
+    !
+    !     3. Compute the diagnostic temperature profile
+    !
+
+    CALL thermosoil_diaglev(kjpindex, stempdiag)
+    !
+    !
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_var_init done '
+
+  END SUBROUTINE thermosoil_var_init
+
+  !! Computation of cgrnd and dgrnd coefficient at the t time-step.
+  !!
+  !! Needs previous time step values.
+  !!
+  SUBROUTINE thermosoil_coef (kjpindex, dtradia, temp_sol_new, snow, ptn, soilcap, soilflx, zz, dz1, dz2, z1, zdz1,&
+           & zdz2, cgrnd, dgrnd, pcapa, pcapa_en, pkappa)
+
+    ! interface description
+    ! input scalar
+    INTEGER(i_std), INTENT(in)                               :: kjpindex          !! Domain size
+    REAL(r_std), INTENT (in)                                 :: dtradia           !! Time step in seconds
+    ! input fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)           :: temp_sol_new      !!
+    REAL(r_std), DIMENSION (kjpindex), INTENT (in)           :: snow              !!
+    REAL(r_std), DIMENSION (ngrnd), INTENT(in)               :: zz                !!
+    REAL(r_std), DIMENSION (ngrnd), INTENT(in)               :: dz1               !!
+    REAL(r_std), DIMENSION (ngrnd), INTENT(in)               :: dz2               !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT (in)     :: ptn
+    ! output fields
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: soilcap           !!
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: soilflx           !!
+    REAL(r_std), DIMENSION (kjpindex), INTENT (out)          :: z1                !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout)     :: pcapa             !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout)     :: pcapa_en          !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(inout)     :: pkappa            !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out)     :: cgrnd             !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out)     :: dgrnd             !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd-1), INTENT(out)     :: zdz1              !!
+    REAL(r_std), DIMENSION (kjpindex,ngrnd), INTENT(out)     :: zdz2              !!
+
+    ! local declaration
+    INTEGER(i_std)                                          :: ji, jg
+    REAL(r_std), DIMENSION(kjpindex)                         :: snow_h, zx1, zx2
+
+    !
+    !   objet:  computation of cgrnd and dgrnd coefficient at the t time-step.
+    !   ------
+    !           
+    !   ---------------------------------------------------------------
+    !   Computation of the Cgrd and Dgrd coefficient for the next step:
+    !   ---------------------------------------------------------------
+    !
+    DO ji = 1,kjpindex
+      snow_h(ji) = snow(ji) / sn_dens
+      !
+      !        Traitement special pour le premiere couche
+      !
+      IF ( snow_h(ji) .GT. zz_coef(1) ) THEN
+          pcapa(ji,1) = sn_capa
+          pcapa_en(ji,1) = sn_capa
+          pkappa(ji,1) = sn_cond
+      ELSE IF ( snow_h(ji) .GT. zero ) THEN
+          pcapa_en(ji,1) = sn_capa
+          zx1(ji) = snow_h(ji) / zz_coef(1)
+          zx2(ji) = ( zz_coef(1) - snow_h(ji)) / zz_coef(1)
+          pcapa(ji,1) = zx1(ji) * sn_capa + zx2(ji) * so_capa_wet
+          pkappa(ji,1) = un / ( zx1(ji) / sn_cond + zx2(ji) / so_cond_wet )
+      ELSE
+          pcapa(ji,1) = so_capa_dry + wetdiag(ji,1)*(so_capa_wet - so_capa_dry)
+          pkappa(ji,1) = so_cond_dry + wetdiag(ji,1)*(so_cond_wet - so_cond_dry)
+          pcapa_en(ji,1) = so_capa_dry + wetdiag(ji,1)*(so_capa_wet - so_capa_dry)
+      ENDIF
+      !
+      DO jg = 2, ngrnd - 2
+        IF ( snow_h(ji) .GT. zz_coef(jg) ) THEN
+            pcapa(ji,jg) = sn_capa
+            pkappa(ji,jg) = sn_cond
+            pcapa_en(ji,jg) = sn_capa
+        ELSE IF ( snow_h(ji) .GT. zz_coef(jg-1) ) THEN
+            zx1(ji) = (snow_h(ji) - zz_coef(jg-1)) / (zz_coef(jg) - zz_coef(jg-1))
+            zx2(ji) = ( zz_coef(jg) - snow_h(ji)) / (zz_coef(jg) - zz_coef(jg-1))
+            pcapa(ji,jg) = zx1(ji) * sn_capa + zx2(ji) * so_capa_wet
+            pkappa(ji,jg) = un / ( zx1(ji) / sn_cond + zx2(ji) / so_cond_wet )
+            pcapa_en(ji,jg) = sn_capa
+        ELSE
+            pcapa(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
+            pkappa(ji,jg) = so_cond_dry + wetdiag(ji,jg)*(so_cond_wet - so_cond_dry)
+            pcapa_en(ji,jg) = so_capa_dry + wetdiag(ji,jg)*(so_capa_wet - so_capa_dry)
+        ENDIF
+      ENDDO
+     !
+     !
+    ENDDO
+    !
+    DO jg=1,ngrnd
+      DO ji=1,kjpindex
+        zdz2(ji,jg)=pcapa(ji,jg) * dz2(jg)/dtradia
+      ENDDO
+    ENDDO
+    !
+    DO jg=1,ngrnd-1
+      DO ji=1,kjpindex
+        zdz1(ji,jg) = dz1(jg) * pkappa(ji,jg)
+      ENDDO
+    ENDDO
+    !
+    DO ji = 1,kjpindex
+      z1(ji) = zdz2(ji,ngrnd) + zdz1(ji,ngrnd-1)
+      cgrnd(ji,ngrnd-1) = zdz2(ji,ngrnd) * ptn(ji,ngrnd) / z1(ji)
+      dgrnd(ji,ngrnd-1) = zdz1(ji,ngrnd-1) / z1(ji)
+    ENDDO
+
+    DO jg = ngrnd-1,2,-1
+      DO ji = 1,kjpindex
+        z1(ji) = un / (zdz2(ji,jg) + zdz1(ji,jg-1) + zdz1(ji,jg) * (un - dgrnd(ji,jg)))
+        cgrnd(ji,jg-1) = (ptn(ji,jg) * zdz2(ji,jg) + zdz1(ji,jg) * cgrnd(ji,jg)) * z1(ji)
+        dgrnd(ji,jg-1) = zdz1(ji,jg-1) * z1(ji)
+      ENDDO
+    ENDDO
+
+    !   ---------------------------------------------------------
+    !   computation of the surface diffusive flux from ground and
+    !   calorific capacity of the ground:
+    !   ---------------------------------------------------------
+
+    DO ji = 1,kjpindex
+      soilflx(ji) = zdz1(ji,1) * (cgrnd(ji,1) + (dgrnd(ji,1)-1.) * ptn(ji,1))
+      soilcap(ji) = (zdz2(ji,1) * dtradia + dtradia * (un - dgrnd(ji,1)) * zdz1(ji,1))
+      z1(ji) = lambda * (un - dgrnd(ji,1)) + un
+      soilcap(ji) = soilcap(ji) / z1(ji)
+      soilflx(ji) = soilflx(ji) + &
+         & soilcap(ji) * (ptn(ji,1) * z1(ji) - lambda * cgrnd(ji,1) - temp_sol_new(ji)) / dtradia 
+    ENDDO
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_coef done '
+
+  END SUBROUTINE thermosoil_coef
+
+  !! Computation of : the ground temperature evolution
+  !!  
+  SUBROUTINE thermosoil_profile (kjpindex, temp_sol_new, ptn, stempdiag)
+
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                               :: kjpindex       !! Domain size
+    ! input fields
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)            :: temp_sol_new   !! New soil temperature
+    ! modified fields
+    REAL(r_std),DIMENSION (kjpindex,ngrnd), INTENT (inout)   :: ptn            !! Different levels soil temperature
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out)       :: stempdiag     !! Diagnostoc profile
+
+    ! local declaration
+    INTEGER(i_std)                                          :: ji, jg
+    !
+    !   objet:  computation of : the ground temperature evolution
+    !   ------
+    !
+    !   Method: implicit time integration
+    !   -------
+    !   Consecutives ground temperatures are related by:
+    !           T(k+1) = C(k) + D(k)*T(k)  (1)
+    !   the coefficients C and D are computed at the t-dt time-step.
+    !   Routine structure:
+    !   -new temperatures are computed  using (1)
+    !           
+    !
+    !    surface temperature
+    DO ji = 1,kjpindex
+      ptn(ji,1) = (lambda * cgrnd(ji,1) + temp_sol_new(ji)) / (lambda * (un - dgrnd(ji,1)) + un)
+    ENDDO
+
+    !   other temperatures
+    DO jg = 1,ngrnd-1
+      DO ji = 1,kjpindex
+        ptn(ji,jg+1) = cgrnd(ji,jg) + dgrnd(ji,jg) * ptn(ji,jg)
+      ENDDO
+    ENDDO
+
+    CALL thermosoil_diaglev(kjpindex, stempdiag)
+
+    IF (long_print) WRITE (numout,*) ' thermosoil_profile done '
+
+  END SUBROUTINE thermosoil_profile
+!!
+!!
+!!  Diagnostic soil temperature profile on new levels
+!!
+!!
+  SUBROUTINE thermosoil_diaglev(kjpindex, stempdiag)
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                            :: kjpindex    !! Domain size
+    ! input fields
+    !
+    ! modified fields
+    !
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (out)   :: stempdiag      !! Diagnostoc profile
+    !
+    ! local variable
+    !
+    INTEGER(i_std)  :: ji, jd, jg
+    REAL(r_std)  :: lev_diag, prev_diag, lev_prog, prev_prog
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: intfact
+    !
+    LOGICAL, PARAMETER :: check=.FALSE.
+    !
+    !
+    IF ( .NOT. ALLOCATED(intfact)) THEN
+        !
+        ALLOCATE(intfact(nbdl, ngrnd))
+        !
+        prev_diag = zero
+        DO jd = 1, nbdl
+          lev_diag = diaglev(jd)
+          prev_prog = zero
+          DO jg = 1, ngrnd
+             IF ( jg == ngrnd .AND. (prev_prog + dz2(jg)) < lev_diag ) THEN
+                !! Just make sure we cover the deepest layers
+                lev_prog = lev_diag
+             ELSE
+                lev_prog = prev_prog + dz2(jg)
+             ENDIF
+            intfact(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), zero)/(lev_diag-prev_diag)
+            prev_prog = lev_prog
+          ENDDO
+           prev_diag = lev_diag
+        ENDDO
+        !
+        IF ( check ) THEN
+           WRITE(numout,*) 'thermosoil_diagev -- thermosoil_diaglev -- thermosoil_diaglev --' 
+           DO jd = 1, nbdl
+              WRITE(numout,*) jd, '-', intfact(jd,1:ngrnd)
+           ENDDO
+           WRITE(numout,*) "SUM -- SUM -- SUM SUM -- SUM -- SUM"
+           DO jd = 1, nbdl
+              WRITE(numout,*) jd, '-', SUM(intfact(jd,1:ngrnd))
+           ENDDO
+           WRITE(numout,*) 'thermosoil_diaglev -- thermosoil_diaglev -- thermosoil_diaglev --' 
+        ENDIF
+        !
+    ENDIF
+
+    stempdiag(:,:) = zero
+    DO jg = 1, ngrnd
+      DO jd = 1, nbdl
+        DO ji = 1, kjpindex
+          stempdiag(ji,jd) = stempdiag(ji,jd) + ptn(ji,jg)*intfact(jd,jg)
+        ENDDO
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE thermosoil_diaglev
+!!
+!!
+!!  Put soil wetness on the temperature levels
+!!
+!!
+  SUBROUTINE thermosoil_humlev(kjpindex, shumdiag)
+    ! interface description
+    ! input scalar 
+    INTEGER(i_std), INTENT(in)                            :: kjpindex    !! Domain size
+    ! input fields
+    !
+    ! modified fields
+    !
+    ! output fields
+    REAL(r_std),DIMENSION (kjpindex,nbdl), INTENT (in)   :: shumdiag      !! Diagnostoc profile
+    !
+    ! local variable
+    !
+    INTEGER(i_std)  :: ji, jd, jg
+    REAL(r_std)  :: lev_diag, prev_diag, lev_prog, prev_prog
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:,:) :: intfactw
+    !
+    LOGICAL, PARAMETER :: check=.FALSE.
+    !
+    !
+    IF ( .NOT. ALLOCATED(intfactw)) THEN
+        !
+        ALLOCATE(intfactw(ngrnd, nbdl))
+        !
+        prev_diag = zero
+        DO jd = 1, ngrnd
+          lev_diag = prev_diag + dz2(jd)
+          prev_prog = zero
+          DO jg = 1, nbdl
+             IF ( jg == nbdl .AND. diaglev(jg) < lev_diag ) THEN
+                !! Just make sure we cover the deepest layers
+                lev_prog = lev_diag
+             ELSE
+                lev_prog = diaglev(jg)
+             ENDIF
+             intfactw(jd,jg) = MAX(MIN(lev_diag,lev_prog)-MAX(prev_diag, prev_prog), zero)/(lev_diag-prev_diag)
+             prev_prog = lev_prog
+          ENDDO
+           prev_diag = lev_diag
+        ENDDO
+        !
+        IF ( check ) THEN
+           WRITE(numout,*) 'thermosoil_humlev -- thermosoil_humlev -- thermosoil_humlev --' 
+           DO jd = 1, ngrnd
+              WRITE(numout,*) jd, '-', intfactw(jd,1:nbdl)
+           ENDDO
+           WRITE(numout,*) "SUM -- SUM -- SUM SUM -- SUM -- SUM"
+           DO jd = 1, ngrnd
+              WRITE(numout,*) jd, '-', SUM(intfactw(jd,1:nbdl))
+           ENDDO
+           WRITE(numout,*) 'thermosoil_humlev -- thermosoil_humlev -- thermosoil_humlev --' 
+        ENDIF
+        !
+    ENDIF
+
+    wetdiag(:,:) = zero
+    DO jg = 1, nbdl
+      DO jd = 1, ngrnd
+        DO ji = 1, kjpindex
+          wetdiag(ji,jd) = wetdiag(ji,jd) + shumdiag(ji,jg)*intfactw(jd,jg)
+        ENDDO
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE thermosoil_humlev
+
+  SUBROUTINE thermosoil_energy(kjpindex, temp_sol_new, soilcap, first_call)
+    ! interface description
+    ! input scalar
+    INTEGER(i_std), INTENT(in)                            :: kjpindex    !! Domain size
+    LOGICAL, INTENT (in)                                 :: first_call  !!
+    ! input fields
+    !
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: temp_sol_new !! New soil temperature
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)        :: soilcap      !! Soil capacity
+    !
+    ! modified fields
+    !
+    ! output fields
+    !
+    ! local variable
+    !
+    INTEGER(i_std)  :: ji, jg
+    !
+    !
+    IF (first_call) THEN
+
+     DO ji = 1, kjpindex
+      surfheat_incr(ji) = zero
+      coldcont_incr(ji) = zero
+      temp_sol_beg(ji)  = temp_sol_new(ji)
+      !
+      DO jg = 1, ngrnd
+       ptn_beg(ji,jg)   = ptn(ji,jg)
+      ENDDO
+      !
+     ENDDO
+    
+     RETURN
+
+    ENDIF
+
+     DO ji = 1, kjpindex
+      surfheat_incr(ji) = zero
+      coldcont_incr(ji) = zero
+     ENDDO
+    !
+    !  Sum up the energy content of all layers in the soil.
+    !
+    DO ji = 1, kjpindex
+    !
+       IF (pcapa_en(ji,1) .LE. sn_capa) THEN
+          !
+          ! Verify the energy conservation in the surface layer
+          !
+          coldcont_incr(ji) = soilcap(ji) * (temp_sol_new(ji) - temp_sol_beg(ji))
+          surfheat_incr(ji) = zero
+       ELSE
+          !
+          ! Verify the energy conservation in the surface layer
+          !
+          surfheat_incr(ji) = soilcap(ji) * (temp_sol_new(ji) - temp_sol_beg(ji))
+          coldcont_incr(ji) = zero
+       ENDIF
+    ENDDO
+    
+    ptn_beg(:,:)      = ptn(:,:)
+    temp_sol_beg(:)   = temp_sol_new(:)
+
+  END SUBROUTINE thermosoil_energy
+
+END MODULE thermosoil
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/watchout.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/watchout.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_sechiba/watchout.f90	(revision 55)
@@ -0,0 +1,2257 @@
+MODULE watchout
+
+  USE defprec
+  USE parallel
+  USE constantes
+  USE netcdf
+
+  PRIVATE
+  PUBLIC :: watchout_init, watchout_write_p, watchout_close
+!watchout_write ??
+
+  LOGICAL,SAVE,PUBLIC             :: ok_watchout = .FALSE.
+  REAL, SAVE,PUBLIC               :: dt_watch = zero
+  INTEGER, SAVE,PUBLIC            :: last_action_watch = 0, &
+       & last_check_watch = 0
+  CHARACTER(LEN=80),SAVE, PUBLIC   :: watchout_file
+
+  ! At module level we need the ids of the variables for the ORCHIDEE_WATCH. They will be 
+  ! shared by the watchout_init and watchout_write routines.
+  ! The flag which will control all this is watchout
+  !
+  INTEGER(i_std),SAVE      :: time_id, timestp_id
+  INTEGER(i_std),SAVE      :: watchfid, zlevid, soldownid, rainfid, snowfid, lwradid, &
+       & psolid, tairid, eairid, qairid, uid, vid, &
+       & solnetid, petAcoefid, peqAcoefid, petBcoefid, peqBcoefid, cdragid, ccanopyid
+  INTEGER(i_std),SAVE      :: watchoffset
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_zlev
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_u, sum_v
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_qair
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_temp_air
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_epot_air
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_ccanopy
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_cdrag
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_petAcoef, sum_peqAcoef, sum_petBcoef, sum_peqBcoef
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_rain, sum_snow
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_lwdown
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_swnet
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_swdown
+  REAL(r_std), ALLOCATABLE, DIMENSION(:), SAVE, PUBLIC  :: sum_pb
+  !! Short wave mean : compute with solar angle, as in readdim2
+!!$  REAL(r_std), ALLOCATABLE, DIMENSION(:,:), SAVE, PUBLIC  :: sinang, mean_sinang
+!!$  INTEGER(i_std), ALLOCATABLE, DIMENSION(:,:), SAVE, PUBLIC :: isinang
+
+  REAL(r_std), PUBLIC :: dt_split_watch
+  !! mean julian time for each time step
+  REAL(r_std), PUBLIC :: julian_watch
+
+CONTAINS 
+SUBROUTINE watchout_init(iim, jjm, kjpindex, igmax, date0, itau, dt, kindex, lon, lat, lev0)
+  !
+  IMPLICIT NONE
+  !
+  ! This routine will allow to set up forcing files for ORCHIDEE. The idea is that
+  ! during a coupled simulation one write's out all the forcing so that ORCHIDEE can
+  ! can be re-run (to equilibrium or for sensitivity) afterwards.
+  !
+  ! INPUT
+  INTEGER(i_std), INTENT(in)   :: iim, jjm, igmax, kjpindex
+  REAL(r_std), INTENT(in)      :: date0, dt
+  INTEGER(i_std), INTENT(in)   :: itau, kindex(igmax)
+  REAL(r_std), INTENT(in)      :: lon(iim,jjm), lat(iim,jjm), lev0
+  !
+  ! OUTPUT
+  !
+  !
+  ! LOCAL
+  !
+  INTEGER(i_std)   :: iret, nlonid1, nlatid1, nlevid1, fid, nlandid1, tdimid1
+  INTEGER(i_std)   :: dims(3)
+  INTEGER(i_std)   :: nlonid, nlatid, nlevid, nlandid, varid, contid, resolxid, resolyid
+  INTEGER(i_std), DIMENSION(8)  ::  neighid
+  REAL(r_std)      :: lon_min, lon_max, lat_min, lat_max, lev_min, lev_max
+  INTEGER(i_std)   :: yy, mm, dd, hh, mn, i, j, ig, direction
+  REAL(r_std)      :: ss
+  REAL(r_std),ALLOCATABLE :: tmpdata(:,:)
+  CHARACTER(LEN=3)  :: cal(12)
+  CHARACTER(LEN=10) :: today, att, axx
+  CHARACTER(LEN=30) :: str30
+  CHARACTER(LEN=70) :: str70, var, unit, titre, assoc
+  CHARACTER(LEN=80) :: stamp, lon_name, lat_name, land_name,time_name
+  !    
+  INTEGER,PARAMETER :: kind_r_watch=nf90_real8
+  !
+  ! Only root proc write watchout file
+  IF (is_root_prc) THEN
+
+     cal(1) = 'JAN'
+     cal(2) = 'FEB'
+     cal(3) = 'MAR'
+     cal(4) = 'APR'
+     cal(5) = 'MAY'
+     cal(6) = 'JUN'
+     cal(7) = 'JUL'
+     cal(8) = 'AUG'
+     cal(9) = 'SEP'
+     cal(10) = 'OCT'
+     cal(11) = 'NOV'
+     cal(12) = 'DEC'
+     !
+     iret = NF90_CREATE (TRIM(watchout_file), NF90_CLOBBER, fid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not create file :',TRIM(watchout_file), &
+             &          '(Problem with disk place or filename ?)')
+     ENDIF
+     !
+     !   Dimensions
+     !
+     iret = NF90_DEF_DIM(fid, 'x', iim, nlonid1)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Dimension "x" can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_DEF_DIM(fid, 'y', jjm, nlatid1)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Dimension "y" can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_DEF_DIM(fid, 'z', 1, nlevid1)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Dimension "z" can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_DEF_DIM(fid, 'land', igmax, nlandid1)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Dimension "land" can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_DEF_DIM(fid, 'tstep', NF90_UNLIMITED, tdimid1)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Dimension "tstep" can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     !   Coordinate  VARIABLES
+     !
+     dims(1) = nlonid1
+     dims(2) = nlatid1
+     !
+     lon_name = 'nav_lon'
+     iret = NF90_DEF_VAR(fid, lon_name, kind_r_watch, dims(1:2), nlonid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//lon_name//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlonid, 'units', "degrees_east") 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lon_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     lon_min = -180.
+     lon_max = 180.
+     !
+     iret = NF90_PUT_ATT(fid, nlonid, 'valid_min', lon_min)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lon_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlonid, 'valid_max', lon_max)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lon_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_ATT(fid, nlonid, 'long_name', "Longitude")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lon_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     lat_name = 'nav_lat'
+     iret = NF90_DEF_VAR(fid, lat_name, kind_r_watch, dims(1:2), nlatid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//lat_name//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlatid, 'units', "degrees_north")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     lat_max = 90.
+     lat_min = -90.
+     !
+     iret = NF90_PUT_ATT(fid, nlatid, 'valid_min', lat_min)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlatid, 'valid_max', lat_max)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlatid, 'long_name', "Latitude")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     lat_name = 'level'
+     iret = NF90_DEF_VAR(fid, lat_name, kind_r_watch,(/ nlevid1 /), nlevid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//lat_name//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlevid, 'units', "m")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     lev_max = lev0
+     lev_min = lev0
+     !
+     iret = NF90_PUT_ATT(fid, nlevid, 'valid_min', lev_min)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlevid, 'valid_max', lev_max)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlevid, 'long_name', "Vertical levels")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//lat_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     !
+     land_name = 'land'
+     iret = NF90_DEF_VAR(fid, land_name, NF90_INT, (/ nlandid1 /), nlandid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//land_name//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, nlandid, 'compress', "y x") 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//land_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     !   Time in real days !
+     !
+     time_name = 'time'
+     iret = NF90_DEF_VAR(fid, time_name, kind_r_watch, (/ tdimid1 /), time_id)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//time_name//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     ! Compute an itau offset so that we can relate the itau of the model
+     ! to the position in the file
+     !
+     watchoffset = itau
+     !
+    CALL ju2ymds(date0, yy, mm, dd, ss)
+    hh = INT(ss/3600.)
+    ss = ss - hh*3600.
+     mn = INT(ss/60.) 
+     ss = ss - mn*60.
+    WRITE(str70,7000) yy, mm, dd, hh, mn, INT(ss)
+!!MM : Time axis by month : 
+!$     hh = INT(sec/3600.)
+!$     ss = sec - hh*3600.
+!$     mn = INT(ss/60.) 
+!$     ss = ss - mn*60.
+!$     WRITE(str70,7000) year, month, day, hh, mn, INT(ss)
+     !
+     iret = NF90_PUT_ATT(fid, time_id, 'units', TRIM(str70))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     CALL ioget_calendar(str30)
+     iret = NF90_PUT_ATT(fid, time_id, 'calendar', TRIM(str30))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_ATT(fid, time_id, 'title', 'Time')
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_ATT(fid, time_id, 'long_name', 'Time axis')
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+    WRITE(str70,7001) yy, cal(mm), dd, hh, mn, INT(ss)
+!!MM : Time axis by month : 
+!$     WRITE(str70,7001) year, CAL(month), day, hh, mn, INT(ss)
+     iret = NF90_PUT_ATT(fid, time_id, 'time_origin', TRIM(str70))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     !   Time steps
+     !
+     time_name = 'timestp'
+     iret = NF90_DEF_VAR(fid, time_name, NF90_INT, (/ tdimid1 /), timestp_id)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//time_name//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+    WRITE(str70,7002) yy, mm, dd, hh, mn, INT(ss)
+!!MM : Time axis by month : 
+!$     WRITE(str70,7002) year, month, day, hh, mn, INT(ss)
+     iret = NF90_PUT_ATT(fid, timestp_id, 'units', TRIM(str70))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_ATT(fid, timestp_id, 'title', 'Time steps')
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_ATT(fid, timestp_id, 'tstep_sec', dt)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_ATT(fid, timestp_id, 'long_name', 'Time step axis')
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+    WRITE(str70,7001) yy, cal(mm), dd, hh, mn, INT(ss)
+!!MM : Time axis by month : 
+!$     WRITE(str70,7001) year, CAL(month), day, hh, mn, INT(ss)
+     iret = NF90_PUT_ATT(fid, timestp_id, 'time_origin', TRIM(str70))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//time_name//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+7000 FORMAT('seconds since ', I4.4,'-',I2.2,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)
+7001 FORMAT(' ', I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)
+7002 FORMAT('timesteps since ', I4.4,'-',I2.2,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2)
+     !
+
+     dims(1) = nlandid1
+     dims(2) = tdimid1
+
+     assoc = 'time (nav_lat nav_lon)'
+     axx='TYX'
+     !
+     var = 'SWdown'
+     unit = 'W/m^2'
+     titre = 'Surface incident shortwave radiation'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     soldownid = varid
+     !
+     var = 'SWnet'
+     unit = 'W/m^2'
+     titre = 'Net surface short-wave flux'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     solnetid = varid
+     !
+     var = 'Rainf'
+     unit = 'Kg/m^2s'
+     titre = 'Rainfall rate'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     rainfid = varid
+     !
+     var = 'Snowf'
+     unit = 'Kg/m^2s'
+     titre = 'Snowfall rate'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     snowfid = varid
+     !
+     var = 'LWdown'
+     unit = 'W/m^2'
+     titre = 'Surface incident longwave radiation'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     lwradid = varid
+     !
+     var = 'PSurf'
+     unit = 'Pa'
+     titre = 'Surface pressure'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     psolid = varid
+     !
+     !
+     !  3D Variables to be written
+     !
+     dims(1) = nlandid1
+     dims(2) = nlevid1
+     dims(3) = tdimid1
+     !
+     assoc = 'time level (nav_lat nav_lon)'
+     axx='TZYX'
+     !
+     lat_name = 'levels'
+     iret = NF90_DEF_VAR(fid, lat_name, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', "m")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', "Vertical levels")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     lev_min = 2.
+     lev_max = 100.
+     iret = NF90_PUT_ATT(fid, varid, 'valid_min', lev_min)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'valid_max', lev_max)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     zlevid = varid
+     !
+     !
+     var = 'Tair'
+     unit = 'K'
+     titre = 'Near surface air temperature'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     tairid = varid
+     !
+     var = 'Eair'
+     unit = 'J/m^2'
+     titre = 'Air potential energy'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     eairid = varid
+     !
+     var = 'Qair'
+     unit = 'Kg/Kg'
+     titre = 'Near surface specific humidity'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     qairid = varid
+     !
+     var = 'Wind_N'
+     unit = 'm/s'
+     titre = 'Near surface northward wind component'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     uid = varid
+     !
+     var = 'Wind_E'
+     unit = 'm/s'
+     titre = 'Near surface eastward wind component'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     vid = varid
+     !
+     var = 'petAcoef'
+     unit = '-'
+     titre = 'Coeficients A from the PBL resolution for T'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     petAcoefid = varid
+     !
+     var = 'peqAcoef'
+     unit = '-'
+     titre = 'Coeficients A from the PBL resolution for q'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     peqAcoefid = varid
+     !
+     var = 'petBcoef'
+     unit = '-'
+     titre = 'Coeficients B from the PBL resolution for T'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     petBcoefid = varid
+     !
+     var = 'peqBcoef'
+     unit = '-'
+     titre = 'Coeficients B from the PBL resolution for q'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     peqBcoefid = varid
+     !
+     var = 'cdrag'
+     unit = '-'
+     titre = 'Surface drag'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     cdragid = varid
+     !
+     !
+     var = 'ccanopy'
+     unit = '-'
+     titre = 'CO2 concentration in the canopy'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:3), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     ccanopyid = varid
+     !
+     !
+     ! Time fixed variable
+     !
+     dims(1) = nlonid1
+     dims(2) = nlatid1
+     !
+     var = 'contfrac'
+     unit = '-'
+     titre = 'Fraction of continent'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     contid=varid
+     !
+     !
+     var = 'neighboursNN'
+     unit = '-'
+     titre = 'indices of North neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(1)=varid
+     !
+     var = 'neighboursNE'
+     unit = '-'
+     titre = 'indices of North-East neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(2)=varid
+     !
+     var = 'neighboursEE'
+     unit = '-'
+     titre = 'indices of East neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(3)=varid
+     !
+     var = 'neighboursSE'
+     unit = '-'
+     titre = 'indices of South-East neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(4)=varid
+     !
+     var = 'neighboursSS'
+     unit = '-'
+     titre = 'indices of South neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(5)=varid
+     !
+     var = 'neighboursSW'
+     unit = '-'
+     titre = 'indices of South-West neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(6)=varid
+     !
+     var = 'neighboursWW'
+     unit = '-'
+     titre = 'indices of West neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(7)=varid
+     !
+     var = 'neighboursNW'
+     unit = '-'
+     titre = 'indices of North-West neighbours of each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     neighid(8)=varid
+     !
+     !
+     var = 'resolutionX'
+     unit = 'm'
+     titre = 'resolution in x at each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     resolxid=varid
+     !
+     var = 'resolutionY'
+     unit = 'm'
+     titre = 'resolution in y at each grid point'
+     assoc = 'nav_lat nav_lon'
+     axx='YX'
+     iret = NF90_DEF_VAR(fid,var, kind_r_watch, dims(1:2), varid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &         'Variable '//var//' can not be defined for the file : ', &
+             &         TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'axis',  TRIM(axx) )
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'units', TRIM(unit)) 
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'long_name', TRIM(titre))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'associate', TRIM(assoc))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, varid, 'missing_value', undef_sechiba)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add attribut to variable '//var//' for the file :', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     resolyid=varid
+     !
+     !
+     !  Global attributes
+     !
+     CALL DATE_AND_TIME(today, att)
+     stamp = "Forcing generated by intersurf in a previous run "//today(1:LEN_TRIM(today))//" at "//att(1:LEN_TRIM(att))
+     iret = NF90_PUT_ATT(fid, NF90_GLOBAL, 'Conventions', "GDT 1.2")
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add global attribut to the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, NF90_GLOBAL, 'file_name', TRIM(watchout_file))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add global attribut to the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     iret = NF90_PUT_ATT(fid, NF90_GLOBAL, 'production', TRIM(stamp))
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not add global attribut to the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_ENDDEF(fid)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not end definitions in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     !    Write coordinates
+     !
+     iret = NF90_PUT_VAR(fid, nlonid, lon)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not put variable nav_lon  in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_VAR(fid, nlatid, lat)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not put variable nav_lat  in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_VAR(fid, nlevid, lev0)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not put variable level  in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     iret = NF90_PUT_VAR(fid, nlandid, kindex)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not put variable land  in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     IF ( .NOT. ALLOCATED(tmpdata)) THEN
+        ALLOCATE(tmpdata(iim,jjm))
+     ENDIF
+     !
+     tmpdata(:,:) = undef_sechiba
+     DO ig=1,igmax
+
+        j = ((kindex(ig)-1)/iim) + 1
+        i = (kindex(ig) - (j-1)*iim)
+
+        tmpdata(i,j) = contfrac_g(ig)
+
+     ENDDO
+     iret = NF90_PUT_VAR(fid, contid, tmpdata)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not put variable contfrac  in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !    
+     DO direction=1,8
+        tmpdata(:,:) = undef_sechiba
+        DO ig=1,igmax
+
+           j = ((kindex(ig)-1)/iim) + 1
+           i = (kindex(ig) - (j-1)*iim)
+
+           tmpdata(i,j) = REAL( neighbours_g(ig,direction) )
+
+        ENDDO
+        iret = NF90_PUT_VAR(fid, neighid(direction), tmpdata)
+        IF (iret /= NF90_NOERR) THEN
+           CALL ipslerr (3,'watchout_init', &
+                &             'Could not put variable neighbours  in the file : ', &
+                &             TRIM(watchout_file),'(Solution ?)')
+        ENDIF
+     ENDDO
+     !
+     tmpdata(:,:) = undef_sechiba
+     DO ig=1,igmax
+
+        j = ((kindex(ig)-1)/iim) + 1
+        i = (kindex(ig) - (j-1)*iim)
+
+        tmpdata(i,j) = resolution_g(ig,1)
+
+     ENDDO
+     iret = NF90_PUT_VAR(fid, resolxid, tmpdata)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not put variable resolutionx  in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     tmpdata(:,:) = undef_sechiba
+     DO ig=1,igmax
+
+        j = ((kindex(ig)-1)/iim) + 1
+        i = (kindex(ig) - (j-1)*iim)
+
+        tmpdata(i,j) = resolution_g(ig,2)
+
+     ENDDO
+     iret = NF90_PUT_VAR(fid, resolyid, tmpdata)
+     IF (iret /= NF90_NOERR) THEN
+        CALL ipslerr (3,'watchout_init', &
+             &          'Could not put variable resolutiony  in the file : ', &
+             &          TRIM(watchout_file),'(Solution ?)')
+     ENDIF
+     !
+     DEALLOCATE(tmpdata)
+     !
+     watchfid = fid
+     !
+  ENDIF
+  !
+  ALLOCATE(sum_zlev(kjpindex))
+  ALLOCATE(sum_u(kjpindex), sum_v(kjpindex))
+  ALLOCATE(sum_qair(kjpindex))
+  ALLOCATE(sum_temp_air(kjpindex))
+  ALLOCATE(sum_epot_air(kjpindex))
+  ALLOCATE(sum_ccanopy(kjpindex))
+  ALLOCATE(sum_cdrag(kjpindex))
+  ALLOCATE(sum_petAcoef(kjpindex), sum_peqAcoef(kjpindex), sum_petBcoef(kjpindex), sum_peqBcoef(kjpindex))
+  ALLOCATE(sum_rain(kjpindex), sum_snow(kjpindex))
+  ALLOCATE(sum_lwdown(kjpindex))
+  ALLOCATE(sum_swnet(kjpindex))
+  ALLOCATE(sum_swdown(kjpindex))
+  ALLOCATE(sum_pb(kjpindex))
+!!$  ALLOCATE(mean_sinang(iim,jjm))
+!!$  ALLOCATE(sinang(iim,jjm))
+!!$  ALLOCATE(isinang(iim,jjm))
+
+  sum_zlev(:) = zero
+  sum_u(:) = zero
+  sum_v(:) = zero
+  sum_qair(:) = zero
+  sum_temp_air(:) = zero
+  sum_epot_air(:) = zero
+  sum_ccanopy(:) = zero
+  sum_cdrag(:) = zero
+  sum_petAcoef(:) = zero
+  sum_peqAcoef(:) = zero
+  sum_petBcoef(:) = zero
+  sum_peqBcoef(:) = zero
+  sum_rain(:) = zero
+  sum_snow(:) = zero
+  sum_lwdown(:) = zero
+  sum_swnet(:) = zero
+  sum_swdown(:) = zero
+  sum_pb(:) = zero
+
+!!$  mean_sinang(:,:) = zero
+!!$  sinang(:,:) = zero
+!!$  isinang(:,:) = dt_split_watch
+
+END SUBROUTINE watchout_init
+  !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+  SUBROUTINE watchout_write_p(igmax, itau, dt, levels, &
+       &                        soldown, rain, snow, lwdown, psurf, temp, eair, qair, u, v, &
+       &                        solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy )
+    !
+    ! 
+    IMPLICIT NONE
+    !
+    ! INPUT
+    !
+    INTEGER(i_std), INTENT(in) :: igmax, itau
+    REAL(r_std), INTENT(inout) :: levels(igmax)
+    REAL(r_std), DIMENSION(igmax), INTENT(inout) :: soldown, rain, snow, lwdown, psurf, &
+         &                                      solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         &                                      cdrag, ccanopy
+    REAL(r_std), INTENT(inout) :: temp(igmax), eair(igmax), qair(igmax), u(igmax), v(igmax)
+    REAL(r_std), INTENT(in) :: dt
+    !
+    ! LOCAL
+    !
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: levels_g
+    REAL(r_std), SAVE, ALLOCATABLE, DIMENSION(:) :: soldown_g, rain_g, snow_g, lwdown_g, psurf_g, &
+         &                             solnet_g, petAcoef_g, peqAcoef_g, petBcoef_g, peqBcoef_g, cdrag_g, &
+         &                             temp_g, eair_g, qair_g, u_g, v_g, ccanopy_g
+    !
+    LOGICAL, SAVE                          :: is_first_time=.TRUE.
+    INTEGER(i_std)                         :: ier
+
+    IF (is_first_time .AND. is_root_prc) THEN
+       ALLOCATE(levels_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in levels_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(soldown_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in soldown_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(rain_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in rain_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(snow_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in snow_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(lwdown_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in lwdown_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(psurf_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in psurf_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(solnet_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in solnet_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(petAcoef_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in petAcoef_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(peqAcoef_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in peqAcoef_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(petBcoef_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in petBcoef_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(peqBcoef_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in peqBcoef_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(cdrag_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in cdrag_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(temp_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in temp_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(eair_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in eair_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(qair_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in qair_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(u_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in u_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(v_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in v_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+
+       ALLOCATE(ccanopy_g(nbp_glo),stat=ier)
+       IF (ier .NE. 0) THEN
+          WRITE (numout,*) ' error in ccanopy_g allocation. We stop. We need iim words = ',nbp_glo
+          STOP 'watchout_write_p'
+       ENDIF
+    ENDIF
+    is_first_time=.FALSE.
+
+    CALL gather(levels,levels_g)
+    CALL gather(soldown,soldown_g)
+    CALL gather(rain,rain_g)
+    CALL gather(snow,snow_g)
+    CALL gather(lwdown,lwdown_g)
+    CALL gather(psurf,psurf_g)
+    CALL gather(solnet,solnet_g)
+    CALL gather(petAcoef,petAcoef_g)
+    CALL gather(peqAcoef,peqAcoef_g)
+    CALL gather(petBcoef,petBcoef_g)
+    CALL gather(peqBcoef,peqBcoef_g)
+    CALL gather(cdrag,cdrag_g)
+    CALL gather(temp,temp_g)
+    CALL gather(eair,eair_g)
+    CALL gather(qair,qair_g)
+    CALL gather(u,u_g)
+    CALL gather(v,v_g)
+    CALL gather(ccanopy,ccanopy_g)
+
+    IF (is_root_prc) THEN
+      CALL watchout_write(nbp_glo, itau, dt, levels_g, &
+       &                      soldown_g, rain_g, snow_g, lwdown_g, psurf_g, temp_g, eair_g, qair_g, u_g, v_g, &
+       &                      solnet_g, petAcoef_g, peqAcoef_g, petBcoef_g, peqBcoef_g, cdrag_g, ccanopy_g )
+    ENDIF
+
+    levels(:) = zero
+    soldown(:) = zero
+    rain(:) = zero
+    snow(:) = zero
+    lwdown(:) = zero
+    psurf(:) = zero
+    solnet(:) = zero
+    petAcoef(:) = zero
+    peqAcoef(:) = zero
+    petBcoef(:) = zero
+    peqBcoef(:) = zero
+    cdrag(:) = zero
+    temp(:) = zero
+    eair(:) = zero
+    qair(:) = zero
+    u(:) = zero
+    v(:) = zero
+    ccanopy(:) = zero
+
+!!$    mean_sinang(:,:) = zero
+!!$    isinang(:,:) = dt_split_watch
+
+  END SUBROUTINE watchout_write_p
+
+  SUBROUTINE watchout_write(igmax, itau, dt, levels, &
+       &                        soldown, rain, snow, lwdown, psurf, temp, eair, qair, u, v, &
+       &                        solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, cdrag, ccanopy )
+    !
+    ! 
+    IMPLICIT NONE
+    !
+    ! This subroutine will write to the file the current fields which force the
+    ! land-surface scheme. It will be in exactly the same format as the other forcing
+    ! files, i.e. ALMA convention !
+    !
+    !
+    ! INPUT
+    !
+    INTEGER(i_std) :: igmax, itau
+    REAL(r_std) :: levels(igmax)
+    REAL(r_std), DIMENSION(igmax), INTENT(in) :: soldown, rain, snow, lwdown, psurf, &
+         &                                      solnet, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         &                                      cdrag, ccanopy
+    REAL(r_std) :: temp(igmax), eair(igmax), qair(igmax), u(igmax), v(igmax)
+    REAL(r_std) :: dt
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std) :: iret
+    INTEGER(i_std) :: corner(3), edges(3)
+    REAL(r_std) :: timestp
+    LOGICAL    :: check=.FALSE.
+    REAL(r_std),ALLOCATABLE :: tmpdata(:)
+    INTEGER(i_std) :: corner_tstp
+    !
+    ! For dt_watch non equal to dt :
+    !
+    corner_tstp = NINT((itau - watchoffset)/dt_split_watch)
+    !
+    corner(1) = corner_tstp
+    edges(1) = 1
+    IF ( check ) &
+         WRITE(numout,*) 'watchout_write corners, edges : ', corner(1), edges(1)
+    !
+    timestp = itau/dt_split_watch
+!!MM : Time axis by month : 
+!$    timestp = (itau - watchoffset)/dt_split_watch
+    IF ( check ) &
+         WRITE(numout,*) "watchout_write : timestp = ",timestp
+    iret = NF90_PUT_VAR(watchfid, timestp_id, (/ timestp /), &
+         &              start=(/ corner(1) /), count=(/ edges(1) /))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable timestp  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    timestp=timestp*dt_watch
+    IF ( check ) &
+         WRITE(numout,*) "watchout_write : time = ",timestp
+    iret = NF90_PUT_VAR(watchfid, time_id, (/ timestp /), &
+         &              start=(/ corner(1) /), count=(/ edges(1) /))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable time  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    corner(1) = 1
+    edges(1) = igmax
+    corner(2) = corner_tstp
+    edges(2) = 1
+    !
+    IF ( .NOT. ALLOCATED(tmpdata)) THEN
+       ALLOCATE(tmpdata(igmax))
+    ENDIF
+    !
+    ! 2D
+    IF ( check ) THEN
+       WRITE(numout,*) '--',itau, ' SOLDOWN : ', MINVAL(soldown), MAXVAL(soldown)
+    ENDIF
+    iret = NF90_PUT_VAR(watchfid, soldownid, soldown, start=corner(1:2), count=edges(1:2))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable SWdown  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    iret = NF90_PUT_VAR(watchfid, solnetid, solnet, start=corner(1:2), count=edges(1:2))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable SWnet  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    ! Bring back to kg/m^2/s
+    !
+    tmpdata = rain/dt
+    IF ( check ) THEN
+       WRITE(numout,*) '--',itau, ' RAIN : ', MINVAL(tmpdata), MAXVAL(tmpdata)
+    ENDIF
+    iret = NF90_PUT_VAR(watchfid, rainfid, tmpdata, start=corner(1:2), count=edges(1:2))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable Rainf  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    tmpdata = snow/dt
+    iret = NF90_PUT_VAR(watchfid, snowfid, tmpdata, start=corner(1:2), count=edges(1:2))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable Snowf  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    iret = NF90_PUT_VAR(watchfid, lwradid, lwdown, start=corner(1:2), count=edges(1:2)) 
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable LWdown  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    !  Bring back to Pa
+    !
+    tmpdata = psurf*100.
+    iret = NF90_PUT_VAR(watchfid, psolid, tmpdata, start=corner(1:2), count=edges(1:2))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable PSurf  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    ! 3D
+    corner(2) = 1
+    edges(2) = 1
+    corner(3) = corner_tstp
+    edges(3) = 1
+    !
+    iret = NF90_PUT_VAR(watchfid, zlevid, levels, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable levels  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    iret = NF90_PUT_VAR(watchfid, tairid, temp, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable Tair  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, eairid, eair, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable Eair  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, qairid, qair, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable Qair  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, uid, u, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable Wind_N  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, vid, v, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable Wind_E  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+    iret = NF90_PUT_VAR(watchfid, petAcoefid, petAcoef, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable petAcoef  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, peqAcoefid, peqAcoef, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable peqAcoef  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, petBcoefid, petBcoef, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable petBcoef  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, peqBcoefid, peqBcoef, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable peqBcoef  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, cdragid, cdrag, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable cdrag  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    iret = NF90_PUT_VAR(watchfid, ccanopyid, ccanopy, start=corner(1:3), count=edges(1:3))
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_write', &
+ &          'Could not put variable ccanopy  in the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+
+    DEALLOCATE(tmpdata)
+    !
+  END SUBROUTINE watchout_write
+  !
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+  SUBROUTINE watchout_close()
+    !
+    !  Close the watch files
+    !
+    IMPLICIT NONE
+    !
+    ! LOCAL
+    !
+    INTEGER(i_std) :: iret
+    LOGICAL       :: check = .FALSE.
+    !
+    !
+    IF ( check )  THEN
+       WRITE(numout,*) 'watchout_close : closing file : ', watchfid
+    ENDIF
+    iret = NF90_CLOSE(watchfid)
+    IF (iret /= NF90_NOERR) THEN
+       CALL ipslerr (3,'watchout_close','Could not close the file : ', &
+ &          TRIM(watchout_file),'(Solution ?)')
+    ENDIF
+    !
+  END SUBROUTINE watchout_close
+
+END MODULE watchout
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/AA_make
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/AA_make	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/AA_make	(revision 55)
@@ -0,0 +1,217 @@
+#-
+#- $Id$
+#-
+PARALLEL_LIB = $(LIBDIR)/libparallel.a
+SXPARALLEL_LIB = $(PARALLEL_LIB)
+#-Q- sxnec  SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx6nec SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- eshpux SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-Q- sx8brodie SXPARALLEL_LIB = $(LIBDIR)/libsxparallel.a
+#-
+PARAM_LIB = $(LIBDIR)/libparameters.a
+SXPARAM_LIB = $(PARAM_LIB)
+#-Q- sxnec  SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx6nec SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- eshpux SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-Q- sx8brodie SXPARAM_LIB = $(LIBDIR)/libsxparameters.a
+#-
+ORGLOB_LIB = $(LIBDIR)/liborglob.a
+SXORGLOB_LIB = $(ORGLOB_LIB)
+#-Q- sxnec  SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- sx6nec SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- eshpux SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-Q- sx8brodie SXORGLOB_LIB = $(LIBDIR)/libsxorglob.a
+#-
+MODS1 = stomate_constants.f90      \
+        lpj_constraints.f90        \
+        lpj_cover.f90              \
+        lpj_crown.f90              \
+        lpj_establish.f90          \
+        lpj_fire.f90               \
+        lpj_gap.f90                \
+        lpj_kill.f90               \
+        lpj_light.f90              \
+        lpj_pftinout.f90           \
+        stomate_alloc.f90          \
+        stomate_data.f90           \
+        stomate_io.f90             \
+        stomate_litter.f90         \
+        stomate_npp.f90            \
+        stomate_phenology.f90      \
+        stomate_prescribe.f90      \
+        stomate_season.f90         \
+        stomate_soilcarbon.f90     \
+        stomate_turnover.f90       \
+        stomate_vmax.f90           \
+        stomate_assimtemp.f90      \
+        stomate_lcchange.f90       \
+        stomate_lpj.f90            \
+        stomate_resp.f90           \
+        stomate.f90
+
+OBJSMODS1 = $(MODS1:.f90=.o)
+#-
+.PRECIOUS : $(MODEL_LIB)
+#-Q- sxnec  .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx6nec .PRECIOUS : $(SXMODEL_LIB)
+#-Q- eshpux .PRECIOUS : $(SXMODEL_LIB)
+#-Q- sx8brodie .PRECIOUS : $(SXMODEL_LIB)
+#-
+all:
+	$(M_K) libparallel
+	$(M_K) libparameters
+	$(M_K) liborglob
+	$(M_K) m_all
+	@echo stomate is OK
+
+m_all: $(MODEL_LIB)($(OBJSMODS1))
+#-Q- intel m_all: WORK_MOD $(MODEL_LIB)($(OBJSMODS1))
+
+memory:
+#-Q- sxnec 	@echo maximum memory must be defined on Rhodes 
+#-Q- sxnec 	@echo in sh or ksh : ulimit -v unlimited 
+#-Q- sxnec 	@echo in csh or tcsh : limit vmemoryuse unlimited 
+#-Q- sxnec 	-/sbin/ulimit -v unlimited
+#-Q- sxnec 	-limit vmemoryuse unlimited
+
+libparallel:
+	(cd ../src_parallel; $(M_K) -f Makefile)
+
+libparameters:
+	(cd ../src_parameters; $(M_K) -f Makefile)
+
+liborglob:
+	(cd ../src_global; $(M_K) -f Makefile)
+
+$(MODEL_LIB)(%.o): %.f90
+	$(F_C) $(F_O) -I$(NCDF_INC) $*.f90
+	$(A_C) $(MODEL_LIB) $*.o
+#-Q- sxnec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sxnec 	mv $*.mod $(MODDIR)
+#-Q- sx6nec 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx6nec 	mv $*.mod $(MODDIR)
+#-Q- eshpux 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- eshpux 	mv $*.mod $(MODDIR)
+#-Q- sx8mercure 	mv $*.mod $(MODDIR)
+#-Q- sx9mercure 	mv $*.mod $(MODDIR)
+#-Q- sx8brodie 	$(A_X) $(SXMODEL_LIB) $*.o
+#-Q- sx8brodie 	mv $*.mod $(MODDIR)
+#-Q- solaris 	mv $*.mod $(MODDIR)
+	$(RM) $*.o
+#-Q- intel
+#-Q- intel WORK_MOD:
+#-Q- intel 	$(RM) work.pcl
+#-Q- intel 	@echo "work.pc" > work.pcl
+#-Q- intel 	@echo "../src_parameters/work.pc" >> work.pcl
+#-Q- intel 	@echo "../../IOIPSL/src/work.pc" >> work.pcl
+
+config: 
+	$(BINDIR)/Fparser -name STOMATE $(MODS1)
+	echo 'Configuration of STOMATE done'
+
+clean:
+	$(RM) $(MODEL_LIB)
+
+$(MODEL_LIB)(stomate.o):          \
+  $(PARAM_LIB)(constantes_co2.o)  \
+  $(MODEL_LIB)(stomate_io.o)      \
+  $(MODEL_LIB)(stomate_lpj.o)
+
+$(MODEL_LIB)(stomate_constants.o): \
+  $(PARAM_LIB)(constantes_veg.o)
+
+$(MODEL_LIB)(lpj_constraints.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_cover.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_crown.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_establish.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_fire.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_gap.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_kill.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_light.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(lpj_pftinout.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_alloc.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_data.o):     \
+  $(PARAM_LIB)(constantes_co2.o)  \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_io.o): \
+  $(MODEL_LIB)(stomate_constants.o) \
+  $(PARALLEL_LIB)(parallel.o)
+
+$(MODEL_LIB)(stomate_litter.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_npp.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_phenology.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_prescribe.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_resp.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_season.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_soilcarbon.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_turnover.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_vmax.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_assimtemp.o): \
+  $(MODEL_LIB)(stomate_constants.o)
+
+$(MODEL_LIB)(stomate_lcchange.o): \
+  $(MODEL_LIB)(stomate_data.o)
+
+$(MODEL_LIB)(stomate_lpj.o):            \
+  $(MODEL_LIB)(lpj_constraints.o)       \
+  $(MODEL_LIB)(lpj_cover.o)             \
+  $(MODEL_LIB)(lpj_crown.o)             \
+  $(MODEL_LIB)(lpj_establish.o)         \
+  $(MODEL_LIB)(lpj_fire.o)              \
+  $(MODEL_LIB)(lpj_gap.o)               \
+  $(MODEL_LIB)(lpj_kill.o)              \
+  $(MODEL_LIB)(lpj_light.o)             \
+  $(MODEL_LIB)(lpj_pftinout.o)          \
+  $(MODEL_LIB)(stomate_alloc.o)         \
+  $(MODEL_LIB)(stomate_data.o)          \
+  $(MODEL_LIB)(stomate_litter.o)        \
+  $(MODEL_LIB)(stomate_npp.o)           \
+  $(MODEL_LIB)(stomate_phenology.o)     \
+  $(MODEL_LIB)(stomate_prescribe.o)     \
+  $(MODEL_LIB)(stomate_season.o)        \
+  $(MODEL_LIB)(stomate_soilcarbon.o)    \
+  $(MODEL_LIB)(stomate_turnover.o)      \
+  $(MODEL_LIB)(stomate_vmax.o)          \
+  $(MODEL_LIB)(stomate_assimtemp.o)     \
+  $(MODEL_LIB)(stomate_resp.o)          \
+  $(MODEL_LIB)(stomate_lcchange.o)
+
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/AA_make.ldef
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/AA_make.ldef	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/AA_make.ldef	(revision 55)
@@ -0,0 +1,18 @@
+#-
+#- $Id$
+#-
+#---------------------------------------------------------------------
+#- Creation des elements relatifs a STOMATE
+#---------------------------------------------------------------------
+SHELL = /bin/sh
+#---------------------------------------------------------------------
+LIBDIR = ../../../lib
+BINDIR = ../../../bin
+MODDIR = $(LIBDIR)
+#---------------------------------------------------------------------
+MODEL_LIB = $(LIBDIR)/libstomate.a
+SXMODEL_LIB = $(MODEL_LIB)
+#-Q- sxnec  SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
+#-Q- sx6nec SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
+#-Q- eshpux SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
+#-Q- sx8brodie SXMODEL_LIB = $(LIBDIR)/libsxstomate.a
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_constraints.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_constraints.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_constraints.f90	(revision 55)
@@ -0,0 +1,205 @@
+! determine whether a PFT is adapted and can regenerate
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_constraints.f90,v 1.8 2009/01/06 15:01:25 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_constraints
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC constraints,constraints_clear
+
+  ! first call
+  LOGICAL, SAVE                                    :: firstcall = .TRUE.
+CONTAINS
+
+
+  SUBROUTINE constraints_clear
+    firstcall = .TRUE. 
+  END SUBROUTINE constraints_clear
+
+  SUBROUTINE constraints (npts, dt, &
+       t2m_month, t2m_min_daily, when_growthinit, &
+       adapted, regenerate)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                              :: npts
+    ! time step (in days)
+    REAL(r_std), INTENT(in)                           :: dt
+    ! "monthly" 2-meter temperature (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)          :: t2m_month
+    ! Daily minimum 2-meter temperature (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)          :: t2m_min_daily
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)     :: when_growthinit
+
+    ! 0.2 output fields
+
+    ! Winter too cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)  :: adapted
+    ! Winter sufficiently cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)  :: regenerate
+
+    ! 0.3 local
+
+    ! Memory length for adaption (d)
+    REAL(r_std)                                       :: tau_adapt
+    ! Memory length for regeneration (d)
+    REAL(r_std)                                       :: tau_regenerate 
+    ! longest sustainable time without regeneration (vernalization)
+    REAL(r_std), PARAMETER                            :: too_long = 5.
+    ! critical value of "regenerate" below which plant dies
+    REAL(r_std)                                       :: regenerate_min
+    ! index
+    INTEGER(i_std)                                    :: j
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering constraints'
+
+    !
+    ! 1 Initializations
+    !
+    tau_adapt = one_year
+    tau_regenerate = one_year
+    !
+    ! 1.1 Messages
+    !
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'constraints:'
+
+       WRITE(numout,*) '   > Memory length for adaption (d): ',tau_adapt
+       WRITE(numout,*) '   > Memory length for regeneration (d): ',tau_regenerate
+       WRITE(numout,*) '   > Longest sustainable time without vernalization (y):', too_long
+       WRITE(numout,*) '   > For trees, longest sustainable time without growth init (y):', &
+            too_long
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 critical value for "regenerate": below this value, the last vernalization
+    !     belong to a too distant past. PFT is then not adapted.
+    !
+
+    regenerate_min = exp ( - too_long * one_year / tau_regenerate )
+
+    !
+    ! 2 Loop over all PFTs
+    !
+
+    DO j = 2,nvm
+
+       IF ( natural(j) .OR. agriculture ) THEN
+
+          !
+          ! 2.1 climate criteria
+          !
+
+          ! 2.1.1 Test if PFT is adapted: check daily temperature.
+          !       If too cold, PFT is not adapted.
+
+          IF ( tmin_crit(j) .EQ. undef ) THEN
+
+             ! 2.1.1.1 some PFTs always survive.
+
+             adapted(:,j) = 1.
+
+          ELSE
+
+             ! 2.1.1.2 frost-sensitive PFTs
+
+             WHERE ( t2m_min_daily(:) .LT. tmin_crit(j) )
+                adapted(:,j) = zero
+             ENDWHERE
+
+             ! limited memory: after some time, the cold shock is forgotten.
+             !  ( adapted will approach 1)
+
+             adapted(:,j) = un - ( un - adapted(:,j) ) * (tau_adapt- dt)/tau_adapt
+
+          ENDIF
+
+          !
+          ! 2.1.2 seasonal trees die if leafage does not show a clear seasonality.
+          !       (i.e. if the start of the growing season is never detected).
+          !
+
+          IF ( tree(j) .AND. ( pheno_crit%pheno_model(j) .NE. 'none' ) ) THEN
+
+             WHERE ( when_growthinit(:,j) .GT. too_long*one_year )
+                adapted(:,j) = zero
+             ENDWHERE
+
+          ENDIF
+
+          ! 2.1.3 Test if PFT is regenerative
+          !       check monthly temperature. If sufficiently cold, PFT will be able to
+          !       regenerate for some time.
+
+          IF ( tcm_crit(j) .EQ. undef ) THEN
+
+             ! 2.1.3.1 several PFTs (ex: evergreen) don't need vernalization
+
+             regenerate(:,j) = 1.
+
+          ELSE
+
+             ! 2.1.3.2 PFT needs vernaliztion
+
+             WHERE ( t2m_month(:) .LE. tcm_crit(j) )
+                regenerate(:,j) = un
+             ENDWHERE
+
+             ! limited memory: after some time, the winter is forgotten.
+             !  (regenerate will approach 0)
+
+             regenerate(:,j) = regenerate(:,j) * (tau_regenerate-dt)/tau_regenerate
+
+          ENDIF
+
+          ! 2.1.4 Plants that need vernalization die after a few years if they don't
+          !       vernalize (even if they would not loose their leaves).
+
+          WHERE ( regenerate(:,j) .LE. regenerate_min )
+             adapted(:,j) = zero
+          ENDWHERE
+
+       ELSE
+
+          !
+          ! 2.2 PFT is not natural and agriculture is not allowed -> remove
+          !
+
+          adapted(:,j) = zero
+
+          regenerate(:,j) = zero
+
+       ENDIF
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving constraints'
+
+  END SUBROUTINE constraints
+
+END MODULE lpj_constraints
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_cover.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_cover.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_cover.f90	(revision 55)
@@ -0,0 +1,167 @@
+! recalculate vegetation cover and LAI
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_cover.f90,v 1.9 2010/04/06 15:44:01 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_cover
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC cover
+
+CONTAINS
+
+  SUBROUTINE cover (npts, cn_ind, ind, biomass, &
+       veget_max, veget_max_old, veget, lai, litter, carbon)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                   :: npts
+    ! crown area (m**2) per ind.
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)          :: cn_ind
+    ! density of individuals (1/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)          :: ind
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)          :: veget_max_old
+
+    ! 0.2 modified fields
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)   :: biomass
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)       :: veget_max
+
+    ! 0.3 output
+
+    ! fractional coverage on ground, taking into account LAI (=grid-scale fpc)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)       :: veget
+    ! leaf area index OF AN INDIVIDUAL PLANT
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)         :: lai
+
+    ! metabolic and structural litter, above and below ground (gC/(m**2 of ground))
+    REAL(r_std),DIMENSION(npts,nlitt,nvm,nlevs), INTENT(inout)         :: litter
+    !  carbon pool: active, slow, or passive,(gC/(m**2 of ground))
+    REAL(r_std),DIMENSION(npts,ncarb,nvm), INTENT(inout)               :: carbon
+
+    ! 0.4 local
+
+    ! index
+    INTEGER(i_std)                                         :: i,j
+
+    ! Litter dilution (gC/mÂ²)
+    REAL(r_std),DIMENSION(npts,nlitt,nlevs)                            :: dilu_lit
+    ! Soil Carbondilution (gC/mÂ²)
+    REAL(r_std),DIMENSION(npts,ncarb)                                  :: dilu_soil_carbon
+
+    ! conversion vectors
+    REAL(r_std),DIMENSION(nvm)                                         :: delta_veg
+    ! vecteur de conversion
+    REAL(r_std)                                                        :: delta_veg_sum
+
+    ! =========================================================================
+
+    !
+    ! 1 If the vegetation is dynamic, calculate new maximum vegetation cover for
+    !   natural plants
+    !
+
+    IF ( control%ok_dgvm ) THEN
+
+       veget_max(:,ibare_sechiba) = 1.
+
+       DO j = 2,nvm
+
+          IF ( natural(j) ) THEN
+
+             veget_max(:,j) = ind(:,j) * cn_ind(:,j)
+
+          ENDIF
+
+          veget_max(:,ibare_sechiba) = veget_max(:,ibare_sechiba) - veget_max(:,j)
+
+       ENDDO
+
+       veget_max(:,ibare_sechiba) = MAX( veget_max(:,ibare_sechiba), zero )
+
+    ENDIF
+
+    DO i = 1, npts         
+       ! Generation of the conversion vector
+
+       delta_veg(:) = veget_max(i,:)-veget_max_old(i,:)
+       delta_veg_sum = SUM(delta_veg,MASK=delta_veg.LT.zero)
+
+       dilu_lit(i,:,:) = zero
+       dilu_soil_carbon(i,:) = zero
+       DO j=1, nvm
+          IF ( delta_veg(j) < -min_stomate ) THEN 
+             dilu_lit(i,:,:)=  dilu_lit(i,:,:) - delta_veg(j)*litter(i,:,j,:) / delta_veg_sum
+             dilu_soil_carbon(i,:)=  dilu_soil_carbon(i,:) - delta_veg(j) * carbon(i,:,j) / delta_veg_sum
+          ENDIF
+       ENDDO
+
+       DO j=1, nvm
+          IF ( delta_veg(j) > min_stomate) THEN
+
+             ! Dilution of reservoirs
+
+             ! Litter
+             litter(i,:,j,:)=(litter(i,:,j,:) * veget_max_old(i,j) + dilu_lit(i,:,:) * delta_veg(j)) / veget_max(i,j)
+
+             ! Soil carbon
+             carbon(i,:,j)=(carbon(i,:,j) * veget_max_old(i,j) + dilu_soil_carbon(i,:) * delta_veg(j)) / veget_max(i,j)
+
+          ENDIF
+          !SZ correct biomass to conserve mass since it's defined on veget_max
+          IF(j.GE.2.AND.veget_max_old(i,j).GT.min_stomate.AND.veget_max(i,j).GT.min_stomate) THEN
+             biomass(i,j,:)=biomass(i,j,:)*veget_max_old(i,j)/veget_max(i,j)
+          ENDIF
+
+       ENDDO
+    ENDDO
+
+    !
+    ! 2 Calculate LAI
+    !   The LAI is defined on the space covered by the crown of the plant.
+    !    ( biomass / veget_max ) is in gC/(m**2 covered by the crown)
+    !
+    !MM in Soenke code but not in merge version ; must keep that ??
+!!$    DO j = 2,nvm
+!!$       lai(:,j) = biomass(:,j,ileaf,icarbon)*sla(j)
+!!$    ENDDO
+
+    !
+    ! 3 calculate grid-scale fpc (foliage protected cover)
+    !
+
+    DO j = 2,nvm
+       DO i = 1, npts
+          IF (lai(i,j) == val_exp) THEN               
+             veget(i,j) = veget_max(i,j)
+          ELSE
+             veget(i,j) = veget_max(i,j) * ( un - exp( - lai(i,j) * ext_coeff(j) ) )
+          ENDIF
+       ENDDO
+    ENDDO
+    !
+    veget(:,ibare_sechiba) = un
+    DO j = 2,nvm
+       veget(:,ibare_sechiba) = veget(:,ibare_sechiba) - veget(:,j)
+    ENDDO
+
+  END SUBROUTINE cover
+
+END MODULE lpj_cover
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_crown.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_crown.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_crown.f90	(revision 55)
@@ -0,0 +1,141 @@
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_crown.f90,v 1.12 2009/01/06 15:01:25 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!-
+MODULE lpj_crown
+  !---------------------------------------------------------------------
+  !- calculate individual crown area from stem mass.
+  !---------------------------------------------------------------------
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+  !-
+  IMPLICIT NONE
+  !-
+  ! private & public routines
+  !-
+  PRIVATE
+  PUBLIC crown
+  !-
+CONTAINS
+  !-
+  !===
+  !-
+  SUBROUTINE crown &
+       &  (npts, PFTpresent, ind, biomass, veget_max, cn_ind, height)
+    !---------------------------------------------------------------------
+    ! 0 declarations
+    !-
+    ! 0.1 input
+    !-
+    ! Domain size
+    INTEGER(i_std),INTENT(in) :: npts
+    ! Is pft there
+    LOGICAL,DIMENSION(npts,nvm),INTENT(in) :: PFTpresent
+    ! density of individuals (1/(m**2 of ground))
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: ind
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in) :: biomass
+    !-
+    ! 0.2 modified fields
+    !-
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    !-
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout) :: veget_max
+    !-
+    ! 0.3 output
+    !-
+    ! crown area (m**2) per ind.
+    !-
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: cn_ind
+    !-
+    ! height of vegetation (m)
+    !-
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(inout) :: height
+    !-
+    ! 0.4 local
+    !-
+    ! wood mass of an individual
+    !-
+    REAL(r_std),DIMENSION(npts) :: woodmass
+    !-
+    ! index
+    !-
+    INTEGER(i_std) :: j
+    !-
+    ! stem diameter
+    !-
+    REAL(r_std),DIMENSION(npts) :: dia
+    REAL(r_std),DIMENSION(nvm) :: height_presc_12
+    !---------------------------------------------------------------------
+    !-
+    ! 1 initializations
+    !-
+    ! 1.1 check if DGVM activated
+    !-
+    IF (.NOT.control%ok_dgvm) THEN
+       STOP 'crown: not to be called with static vegetation.'
+    ENDIF
+    !-
+    ! 1.2 initialize output to zero
+    !-
+    cn_ind(:,:) = zero
+    ! no convertion, just cop
+    height_presc_12(1:nvm) = height_presc(1:nvm)
+    !-
+    ! 2 calculate (or prescribe) crown area
+    !-
+    DO j = 2,nvm
+       IF (tree(j)) THEN
+          !-----
+          !---- 2.1 trees
+          !-----
+          IF (natural(j)) THEN
+             !------ 2.1.1 natural
+             WHERE (PFTpresent(:,j) .AND.ind(:,j).GT.min_stomate)
+                !-------- 2.1.1.1 calculate individual wood mass
+                woodmass(:) = &
+                     &         (biomass(:,j,isapabove)+biomass(:,j,isapbelow) &
+                     &         +biomass(:,j,iheartabove)+biomass(:,j,iheartbelow))/ind(:,j)
+                !-------- 2.1.1.2 stem diameter (pipe model)
+                dia(:) = (woodmass(:)/(pipe_density*pi/4.*pipe_tune2)) &
+                     &                **(1./(2.+pipe_tune3))
+                !-------- 2.1.1.3 height
+                height(:,j) = pipe_tune2*(dia(:)**pipe_tune3)
+                WHERE (height(:,j) > height_presc_12(j))
+                   dia(:) = (height_presc_12(j)/pipe_tune2)**(1./pipe_tune3)
+                   height(:,j) = height_presc_12(j)
+                ENDWHERE
+                !-------- 2.1.1.4 crown area: for large truncs, crown area cannot
+                !--------         exceed a certain value, prescribed through maxdia.
+                cn_ind(:,j) = pipe_tune1*MIN(dia(:),maxdia(j))**1.6
+             ENDWHERE
+          ELSE
+             !------ 2.1.2 tree is agricultural - stop
+             STOP 'crown: cannot treat agricultural trees.'
+          ENDIF
+       ELSE
+          !-----
+          !---- 2.2 grasses
+          !-----
+          WHERE (PFTpresent(:,j))
+             !------ 2.2.1 an "individual" is 1 m**2 of grass
+             cn_ind(:,j) = un
+          ENDWHERE
+       ENDIF
+       !---
+       !-- 2.3 recalculate vegetation cover if natural
+       !       ind and cn_ind are 0 if not present
+       !---
+       !SZ isn't this physically inconsistent with the assumptions of sechiba??
+       ! the actual LPJ formulation calculates fpc from maximum LAI, and fpar from actual LAI=veget
+       IF (natural(j).AND.control%ok_dgvm) THEN
+          veget_max(:,j) = ind(:,j) * cn_ind(:,j)
+       ENDIF
+    ENDDO
+    !-------------------
+  END SUBROUTINE crown
+  !-
+  !===
+  !-
+END MODULE lpj_crown
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_establish.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_establish.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_establish.f90	(revision 55)
@@ -0,0 +1,543 @@
+! establishment routine
+! Suppose seed pool >> establishment rate.
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_establish.f90,v 1.9 2009/01/06 15:01:25 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_establish
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC establish,establish_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+CONTAINS
+
+
+  SUBROUTINE establish_clear
+    firstcall = .TRUE.
+  END SUBROUTINE establish_clear
+
+  SUBROUTINE establish (npts, dt, PFTpresent, regenerate, &
+       neighbours, resolution, need_adjacent, herbivores, &
+       precip_annual, gdd0, lm_lastyearmax, &
+       cn_ind, lai, avail_tree, avail_grass, &
+       leaf_age, leaf_frac, &
+       ind, biomass, age, everywhere, co2_to_bm,veget_max)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                  :: npts
+    ! Time step of vegetation dynamics (days)
+    REAL(r_std), INTENT(in)                                     :: dt
+    ! Is pft there
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: PFTpresent
+    ! Winter sufficiently cold
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: regenerate
+    ! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    INTEGER(i_std), DIMENSION(npts,8), INTENT(in)               :: neighbours
+    ! resolution at each grid point in m (1=E-W, 2=N-S)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)                  :: resolution
+    ! in order for this PFT to be introduced, does it have to be present in an
+    !   adjacent grid box?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: need_adjacent
+    ! time constant of probability of a leaf to be eaten by a herbivore (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: herbivores
+    ! annual precipitation (mm/year)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: precip_annual
+    ! growing degree days (C)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: gdd0
+    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: lm_lastyearmax
+    ! crown area of individuals (m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: cn_ind
+    ! leaf area index OF AN INDIVIDUAL PLANT
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: lai
+    ! space availability for trees
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: avail_tree
+    ! space availability for grasses
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: avail_grass
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground 
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: veget_max
+
+    ! 0.2 modified fields
+
+    ! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
+    ! Number of individuals / m2
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: ind
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: biomass
+    ! mean age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: age
+    ! is the PFT everywhere in the grid box or very localized (after its introduction)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: everywhere
+    ! biomass uptaken (gC/(m**2 of total ground)/day)
+    !NV passage 2D
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: co2_to_bm
+
+    ! 0.3 local
+
+    ! time during which a sapling can be entirely eaten by herbivores (d)
+    REAL(r_std)                                                 :: tau_eatup 
+    ! new fpc ( foliage protected cover: fractional coverage )
+    REAL(r_std), DIMENSION(npts,nvm)                           :: fpc_nat
+    ! maximum tree establishment rate, based on climate only
+    REAL(r_std), DIMENSION(npts)                                :: estab_rate_max_climate_tree
+    ! maximum grass establishment rate, based on climate only
+    REAL(r_std), DIMENSION(npts)                                :: estab_rate_max_climate_grass
+    ! maximum tree establishment rate, based on climate and fpc
+    REAL(r_std), DIMENSION(npts)                                :: estab_rate_max_tree
+    ! maximum grass establishment rate, based on climate and fpc
+    REAL(r_std), DIMENSION(npts)                                :: estab_rate_max_grass
+    ! total natural fpc
+    REAL(r_std), DIMENSION(npts)                                :: sumfpc
+    ! total woody fpc
+    REAL(r_std), DIMENSION(npts)                                :: sumfpc_wood
+    ! for trees, measures the total concurrence for available space
+    REAL(r_std), DIMENSION(npts)                                :: spacefight_tree
+    ! for grasses, measures the total concurrence for available space
+    REAL(r_std), DIMENSION(npts)                                :: spacefight_grass
+    ! change in number of individuals /m2 per time step (per day in history file)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: d_ind
+    ! biomass increase (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: bm_new
+    ! stem diameter (m)
+    REAL(r_std), DIMENSION(npts)                                :: dia
+    ! temporary variable
+    REAL(r_std), DIMENSION(npts)                                :: b1
+    ! new sap mass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: sm2
+    ! woodmass of an individual
+    REAL(r_std), DIMENSION(npts)                                :: woodmass
+    ! ratio of hw(above) to total hw, sm(above) to total sm
+    REAL(r_std), DIMENSION(npts)                                :: sm_at
+    ! reduction factor for establishment if many trees or grasses are present
+    REAL(r_std), DIMENSION(npts)                                :: factor
+    ! from how many sides is the grid box invaded
+    INTEGER(i_std)                                              :: nfrontx
+    INTEGER(i_std)                                              :: nfronty
+    ! daily establishment rate is large compared to present number of individuals
+    LOGICAL, DIMENSION(npts)                                   :: many_new
+    ! indices
+    INTEGER(i_std)                                              :: i,j,k,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering establish'
+
+    !
+    ! 1 messages and initialization
+    !
+    tau_eatup = one_year/2.
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'establish:'
+
+       WRITE(numout,*) '   > time during which a sapling can be entirely eaten by herbivores (d): ', &
+            tau_eatup
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 2 recalculate fpc
+    !
+
+    !
+    ! 2.1 Only natural part of the grid cell
+    !
+
+    DO j = 2,nvm
+
+       IF ( natural(j) ) THEN
+          DO i = 1, npts
+             IF (lai(i,j) == val_exp) THEN               
+                fpc_nat(i,j) = cn_ind(i,j) * ind(i,j)
+             ELSE
+                fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * ( un - exp( -lai(i,j) * ext_coeff(j) ) )
+             ENDIF
+          ENDDO
+       ELSE
+
+          fpc_nat(:,j) = zero
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 2.2 total natural fpc on grid
+    !
+
+    sumfpc(:) = SUM( fpc_nat(:,:), DIM=2 )
+
+    !
+    ! 2.3 total woody fpc on grid and number of regenerative tree pfts
+    !
+
+    sumfpc_wood(:) = zero
+    spacefight_tree(:) = zero
+
+    DO j = 2,nvm
+
+       IF ( tree(j) .AND. natural(j) ) THEN
+
+          ! total woody fpc
+
+          WHERE ( PFTpresent(:,j) )
+             sumfpc_wood(:) = sumfpc_wood(:) + fpc_nat(:,j)
+          ENDWHERE
+
+          ! how many trees are competing? Count a PFT fully only if it is present
+          !   on the whole grid box.
+
+          WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
+             spacefight_tree(:) = spacefight_tree(:) + everywhere(:,j)
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 2.4 number of natural grasses
+    !
+
+    spacefight_grass(:) = zero
+
+    DO j = 2,nvm
+
+       IF ( .NOT. tree(j) .AND. natural(j) ) THEN
+
+          ! how many grasses are competing? Count a PFT fully only if it is present
+          !   on the whole grid box.
+
+          WHERE ( PFTpresent(:,j) )
+             spacefight_grass(:) = spacefight_grass(:) + everywhere(:,j)
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 3 establishment rate
+    !
+
+    !
+    ! 3.1 maximum establishment rate, based on climate only
+    !
+
+    WHERE ( ( precip_annual(:) .GE. precip_crit ) .AND. ( gdd0(:) .GE. gdd_crit ) )
+
+       estab_rate_max_climate_tree(:) = estab_max_tree
+       estab_rate_max_climate_grass(:) = estab_max_grass
+
+    ELSEWHERE
+
+       estab_rate_max_climate_tree(:) = zero
+       estab_rate_max_climate_grass(:) = zero
+
+    ENDWHERE
+
+    !
+    ! 3.2 reduce maximum tree establishment rate if many trees present.
+    !     In the original DGVM, this is done using a step function which yields a
+    !     reduction by factor 4 if sumfpc_wood(i) .GT.  fpc_crit - 0.05.
+    !     This can lead to small oscillations (without consequences however).
+    !     Here, a steady linear transition is used between fpc_crit-0.075 and
+    !     fpc_crit-0.025.
+    !
+
+    factor(:) = un - 15. * ( sumfpc_wood(:) - (fpc_crit-.075) )
+    factor(:) = MAX( 0.25_r_std, MIN( 1._r_std, factor(:) ) )
+
+    estab_rate_max_tree(:) = estab_rate_max_climate_tree(:) * factor(:)
+
+    !
+    ! 3.3 Modulate grass establishment rate.
+    !     If canopy is not closed (fpc < fpc_crit-0.05), normal establishment.
+    !     If canopy is closed, establishment is reduced by a factor 4.
+    !     Factor is linear between these two bounds.
+    !     This is different from the original DGVM where a step function is
+    !     used at fpc_crit-0.05 (This can lead to small oscillations,
+    !     without consequences however).
+    !
+
+    factor(:) = un - 15. * ( sumfpc(:) - (fpc_crit-.05) )
+    factor(:) = MAX( 0.25_r_std, MIN( 1._r_std, factor(:) ) )
+
+    estab_rate_max_grass(:) = estab_rate_max_climate_grass(:) * factor(:)
+
+    !
+    ! 4 do establishment for natural PFTs
+    !
+
+    d_ind(:,:) = zero
+
+    DO j = 2,nvm
+
+       ! only for natural PFTs
+
+       IF ( natural(j) ) THEN
+
+          !
+          ! 4.1 PFT expansion across the grid box. Not to be confused with areal
+          !     coverage.
+          !
+
+          IF ( treat_expansion ) THEN
+
+             ! only treat plants that are regenerative and present and still can expand
+
+             DO i = 1, npts
+
+                IF ( PFTpresent(i,j) .AND. &
+                     ( everywhere(i,j) .LT. un ) .AND. &
+                     ( regenerate(i,j) .GT. regenerate_crit ) ) THEN
+
+                   ! from how many sides is the grid box invaded (separate x and y directions
+                   ! because resolution may be strongly anisotropic)
+                   !
+                   ! For the moment we only look into 4 direction but that can be extanded (JP) 
+                   !
+                   nfrontx = 0
+                   IF ( neighbours(i,3) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,3),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1
+                   ENDIF
+                   IF ( neighbours(i,7) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,7),j) .GT. 1.-min_stomate ) nfrontx = nfrontx+1
+                   ENDIF
+
+                   nfronty = 0
+                   IF ( neighbours(i,1) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,1),j) .GT. 1.-min_stomate ) nfronty = nfronty+1
+                   ENDIF
+                   IF ( neighbours(i,5) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,5),j) .GT. 1.-min_stomate ) nfronty = nfronty+1
+                   ENDIF
+
+                   everywhere(i,j) = &
+                        everywhere(i,j) + migrate(j) * dt/one_year * &
+                        ( nfrontx / resolution(i,1) + nfronty / resolution(i,2) )
+
+                   IF ( .NOT. need_adjacent(i,j) ) THEN
+
+                      ! in that case, we also assume that the PFT expands from places within
+                      ! the grid box (e.g., oasis).
+
+                      everywhere(i,j) = &
+                           everywhere(i,j) + migrate(j) * dt/one_year * &
+                           2. * SQRT( pi*everywhere(i,j)/(resolution(i,1)*resolution(i,2)) )
+
+                   ENDIF
+
+                   everywhere(i,j) = MIN( everywhere(i,j), 1._r_std )
+
+                ENDIF
+
+             ENDDO
+
+          ENDIF  ! treat expansion?
+
+          !
+          ! 4.2 establishment rate
+          !     - Is lower if the PFT is only present in a small part of the grid box
+          !       (after its introduction), therefore multiplied by "everywhere".
+          !     - Is divided by the number of PFTs that compete ("spacefight").
+          !     - Is modulated by space availability (avail_tree, avail_grass).
+          !
+
+          IF ( tree(j) ) THEN
+
+             ! 4.2.1 present and regenerative trees
+
+             WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
+
+
+                d_ind(:,j) = estab_rate_max_tree(:)*everywhere(:,j)/spacefight_tree(:) * &
+                     avail_tree(:) * dt/one_year
+
+             ENDWHERE
+
+          ELSE
+
+             ! 4.2.2 present and regenerative grasses
+
+             WHERE ( PFTpresent(:,j) .AND. ( regenerate(:,j) .GT. regenerate_crit ) )
+
+                d_ind(:,j) = estab_rate_max_grass(:)*everywhere(:,j)/spacefight_grass(:) * &
+                     avail_grass(:) * dt/one_year
+
+             ENDWHERE
+
+          ENDIF  ! tree/grass
+
+          !
+          ! 4.3 herbivores reduce establishment rate
+          !     We suppose that saplings are vulnerable during a given time after establishment.
+          !     This is taken into account by preventively reducing the establishment rate.
+          !
+
+          IF ( ok_herbivores ) THEN
+
+             d_ind(:,j) = d_ind(:,j) * EXP( - tau_eatup/herbivores(:,j) )
+
+          ENDIF
+
+          !
+          ! 4.4 be sure that ind*cn_ind does not exceed 1
+          !
+
+          WHERE ( ( d_ind(:,j) .GT. zero ) .AND. &
+               ( (ind(:,j)+d_ind(:,j))*cn_ind(:,j) .GT. un ) )
+
+             d_ind(:,j) = MAX( 1._r_std / cn_ind(:,j) - ind(:,j), 0._r_std )
+
+          ENDWHERE
+
+          !
+          ! 4.5 new properties where there is establishment ( d_ind > 0 )
+          !
+
+          ! 4.5.1 biomass.
+          !       Add biomass only if d_ind, over one year, is of the order of ind.
+          !       (If we don't do this, the biomass density can become very low).
+          !       In that case, take biomass from the atmosphere.
+
+          ! compare establishment rate and present number of inidivuals
+          many_new(:) = ( d_ind(:,j) .GT. 0.1 * ind(:,j) )
+
+          ! gives a better vectorization of the VPP
+
+          IF ( ANY( many_new(:) ) ) THEN
+
+             DO k = 1, nparts
+
+                WHERE ( many_new(:) )
+
+                   bm_new(:) = d_ind(:,j) * bm_sapl(j,k) / veget_max (:,j)
+
+                   biomass(:,j,k) = biomass(:,j,k) + bm_new(:)
+
+                   !NV passage 2D
+                   co2_to_bm(:,j) = co2_to_bm(:,j) + bm_new(:) / dt
+
+                ENDWHERE
+
+             ENDDO
+
+             ! reset leaf ages. Should do a real calculation like in the npp routine, 
+             ! but this case is rare and not worth messing around.
+
+             WHERE ( many_new(:) )
+                leaf_age(:,j,1) = zero
+                leaf_frac(:,j,1) = un
+             ENDWHERE
+
+             DO m = 2, nleafages
+
+                WHERE ( many_new(:) )
+                   leaf_age(:,j,m) = zero
+                   leaf_frac(:,j,m) = zero
+                ENDWHERE
+
+             ENDDO
+
+          ENDIF   ! establishment rate is large
+
+          WHERE ( d_ind(:,j) .GT. zero )
+
+             ! 4.5.2 age decreases
+
+             age(:,j) = age(:,j) * ind(:,j) / ( ind(:,j) + d_ind(:,j) )
+
+             ! 4.5.3 new number of individuals
+
+             ind(:,j) = ind(:,j) + d_ind(:,j)
+
+          ENDWHERE
+
+          !
+          ! 4.6 eventually convert excess sapwood to heartwood
+          !
+
+          IF ( tree(j) ) THEN
+
+             sm2(:) = zero
+
+             WHERE ( d_ind(:,j) .GT. zero ) 
+
+                ! ratio of above / total sap parts
+                sm_at(:) = biomass(:,j,isapabove) / &
+                     ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) )
+
+                ! woodmass of an individual
+
+                woodmass(:) = &
+                     ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) + &
+                     biomass(:,j,iheartabove) + biomass(:,j,iheartbelow) ) / ind(:,j)
+
+                ! crown area (m**2) depends on stem diameter (pipe model)
+                dia(:) = ( woodmass(:) / ( pipe_density * pi/4. * pipe_tune2 ) ) &
+                     ** ( un / ( 2. + pipe_tune3 ) )
+
+                b1(:) = pipe_k1 / ( sla(j) * pipe_density*pipe_tune2 * dia(:)**pipe_tune3 ) * &
+                     ind(:,j)
+                sm2(:) = lm_lastyearmax(:,j) / b1(:)
+
+             ENDWHERE
+
+             WHERE ( ( d_ind(:,j) .GT. zero ) .AND. &
+                  ( biomass(:,j,isapabove) + biomass(:,j,isapbelow) ) .GT. sm2(:) )
+
+                biomass(:,j,iheartabove) = biomass(:,j,iheartabove) + &
+                     ( biomass(:,j,isapabove) - sm2(:) * sm_at(:) )
+                biomass(:,j,isapabove) = sm2(:) * sm_at(:)
+
+                biomass(:,j,iheartbelow) = biomass(:,j,iheartbelow) + &
+                     ( biomass(:,j,isapbelow) - sm2(:) * (un - sm_at) )
+                biomass(:,j,isapbelow) = sm2(:) * (un - sm_at(:))
+
+             ENDWHERE
+
+          ENDIF        ! tree
+
+       ENDIF          ! natural
+
+    ENDDO            ! loop over pfts
+
+    !
+    ! 5 history
+    !
+
+    d_ind = d_ind / dt
+
+    CALL histwrite (hist_id_stomate, 'IND_ESTAB', itime, d_ind, npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving establish'
+
+  END SUBROUTINE establish
+
+END MODULE lpj_establish
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_fire.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_fire.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_fire.f90	(revision 55)
@@ -0,0 +1,559 @@
+! calculate fire extent and impact on plants.
+! This is treated on a pseudo-daily basis (fireindex has a long-term memory).
+! We only take into account the natural litter.
+! Grasses are totally burned.
+! When the vegetation is dynamic, it also decreases the density of individuals.
+! Fire burns litter on the ground.
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_fire.f90,v 1.12 2010/04/06 15:44:01 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_fire
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+  USE parallel
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC fire,fire_clear
+
+  ! first call
+  LOGICAL, SAVE                                                   :: firstcall = .TRUE.
+  ! flag that disable fire
+  LOGICAL, SAVE                                                   :: disable_fire
+
+CONTAINS
+
+
+  SUBROUTINE fire_clear
+    firstcall = .TRUE.
+  END SUBROUTINE fire_clear
+
+  SUBROUTINE fire (npts, dt, litterpart, &
+       litterhum_daily, t2m_daily, lignin_struc, &
+       fireindex, firelitter, biomass, ind, &
+       litter, dead_leaves, bm_to_litter, black_carbon, &
+       co2_fire)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                             :: npts
+    ! Time step in days
+    REAL(r_std), INTENT(in)                                          :: dt
+    ! fraction of litter above the ground belonging to different PFTs
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(in)              :: litterpart
+    ! Daily litter moisture (between 0 and 1)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                         :: litterhum_daily
+    ! Daily 2 meter temperature (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                         :: t2m_daily
+    ! ratio Lignine/Carbon in structural litter, above and below ground,
+    ! (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(in)         :: lignin_struc
+
+    ! 0.2 modified fields
+
+    ! Probability of fire
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: fireindex
+    ! Longer term total natural litter above the ground, gC/m**2 of natural ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: firelitter
+    ! biomass (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)          :: biomass
+    ! density of individuals (1/m**2)
+    REAl(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: ind
+    ! metabolic and structural litter, above and below ground (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs), INTENT(inout):: litter
+    ! dead leaves on ground, per PFT, metabolic and structural,
+    !   in gC/(m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)           :: dead_leaves
+    ! conversion of biomass to litter (gC/(m**2 of average ground)) / day
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)          :: bm_to_litter
+    ! black carbon on the ground (gC/(m**2 of total ground))
+    REAL(r_std), DIMENSION(npts), INTENT(inout)                      :: black_carbon
+
+    ! 0.3 output
+
+    ! carbon emitted into the atmosphere by fire (living and dead biomass)
+    ! (in gC/m**2/day)
+    !NV devient 2D
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                        :: co2_fire
+
+    ! 0.4 local
+
+    ! Time scale for memory of the fire index (days). Validated for one year in the DGVM.
+    !MM Shilong ??
+!!$    REAL(r_std), PARAMETER                                           :: tau_fire = 365.  ! GKtest
+    REAL(r_std), PARAMETER                                           :: tau_fire = 30.  ! GKtest
+    ! Critical litter quantity for fire
+    REAL(r_std), PARAMETER                                           :: litter_crit = 200.
+    ! fire perturbation
+    REAL(r_std), DIMENSION(npts)                                     :: fire_disturb
+    ! what fraction of the plants is burned each day?
+    REAL(r_std), DIMENSION(npts,nvm)                                :: firedeath 
+    ! What fraction of a burned plant compartment goes into the atmosphere
+    !   (rest into litter)
+    REAL(r_std), SAVE, DIMENSION(nparts)                             :: co2frac
+    ! Moisture limit (critical moisture limit)
+    REAL(r_std), DIMENSION(npts)                                     :: moistlimit
+    ! total litter above the ground for a vegetation type (gC/m**2)
+    REAL(r_std), DIMENSION(npts)                                     :: litter_above
+    ! daily fire index
+    REAL(r_std), DIMENSION(npts,nvm)                           :: fireindex_daily
+    ! fire extent, on ground
+    REAL(r_std), DIMENSION(npts, nvm)                          :: firefrac
+    ! residual fraction of exposed structural litter, depending on lignin fraction
+    REAL(r_std), DIMENSION(npts)                                     :: struc_residual
+    ! residue, i.e. exposed carbon - volatilized carbon ( gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                     :: residue
+    ! fraction of residue transformed into black carbon
+    REAL(r_std), DIMENSION(npts)                                     :: bcfrac
+    ! intermediate variable
+    REAL(r_std), DIMENSION(npts)                                     :: x
+    ! annual fire fraction
+    REAL(r_std), DIMENSION(npts)                                     :: aff
+    ! index
+    INTEGER(i_std)                                                  :: j,k,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering fire'
+
+    !
+    ! 1 Initializations
+    !
+
+    IF ( firstcall ) THEN
+
+       !
+       ! 1.1 What fraction of the plant compartment, if burned, is transformed into CO2
+       !
+
+       co2frac(ileaf) = .95
+       co2frac(isapabove) = .95
+       co2frac(isapbelow) = 0.
+       co2frac(iheartabove) = 0.3
+       co2frac(iheartbelow) = 0.
+       co2frac(iroot) = 0.
+       co2frac(ifruit) = .95
+       co2frac(icarbres) = 0.95
+
+       !
+       ! 1.2 messages
+       !
+
+       WRITE(numout,*) 'fire:'
+
+       WRITE(numout,*) '   > temporal inertia of fire probability (d): ',tau_fire
+
+       WRITE(numout,*) '   > fraction of burned biomass that becomes CO2:'
+       WRITE(numout,*) '     leaves: ', co2frac(ileaf)
+       WRITE(numout,*) '     sap above ground: ', co2frac(isapabove)
+       WRITE(numout,*) '     sap below ground: ', co2frac(isapbelow)
+       WRITE(numout,*) '     heartwood above ground: ', co2frac(iheartabove)
+       WRITE(numout,*) '     heartwood below ground: ', co2frac(iheartbelow)
+       WRITE(numout,*) '     roots: ', co2frac(iroot)
+       WRITE(numout,*) '     fruits: ', co2frac(ifruit)
+       WRITE(numout,*) '     carbohydrate reserve: ', co2frac(icarbres)
+
+       WRITE(numout,*) '   > critical litter quantity (gC/m**2): ',litter_crit
+       WRITE(numout,*) '   > We calculate a fire probability on agricultural ground, but'
+       WRITE(numout,*) '       the effective fire fraction is zero.'
+
+       firstcall = .FALSE.
+       !
+       ! 1.3 read the flag that disable fire
+       !
+       !Config  Key  = FIRE_DISABLE
+       !Config  Desc = no fire allowed
+       !Config  Def  = n
+       !Config  Help = With this variable, you can allow or not
+       !Config         the estimation of CO2 lost by fire
+       !
+       disable_fire=.FALSE.
+       CALL getin_p('FIRE_DISABLE', disable_fire)
+    ENDIF
+
+    !
+    ! 1.4 Initialize output
+    !
+
+    co2_fire(:,:) = zero
+    firedeath(:,:) = zero
+    fireindex_daily(:,:) = zero
+    firefrac(:,:) = zero
+
+    !
+    ! 2 Determine fire probability. We calculate this probability (and long-term litter)
+    !   also for agricultural ground, but the fire fraction on agricultural ground is set
+    !   to 0 for the moment.
+    !
+
+
+    DO j = 2,nvm
+
+       ! total litter above the ground, for the vegetation type we are talking about
+
+       litter_above(:) = litter(:,imetabolic,j,iabove) + &
+            litter(:,istructural,j,iabove)
+
+       !
+       ! 2.1 calculate moisture limit. If it stays 0, this means that there is no litter
+       !     on the ground, and this means that there can be no fore.
+       !     Sum over different litter parts from the various PFTs, taking into account the 
+       !       litter flamability which is a function of the PFT. 
+       !     Difference to Stephen Sitch's approach: Daily litter, not annual mean.
+       !     Reason: 1. seems more reasonable.
+       !             2. easier to implement (otherwise, would need moisture limit
+       !                from previous year)
+       !
+
+       moistlimit(:) = zero
+
+       WHERE ( (t2m_daily(:) .GT. ZeroCelsius) .AND. (litter_above(:) .GT. min_stomate) )
+
+          moistlimit(:) = &
+               ( litterpart(:,j,imetabolic)*litter(:,imetabolic,j,iabove) + &
+               litterpart(:,j,istructural)*litter(:,istructural,j,iabove)  ) / &
+               litter_above(:) * flam(j)
+
+       ENDWHERE
+
+       !
+       ! 2.2 daily fire index.
+       !
+       WHERE ( moistlimit(:) .GT. min_stomate )
+
+          ! is a function of litter humidity. Very sensible to STOMATE's time step as
+          ! with larger dt, one misses dry days with very high fireindex ( strongly
+          ! nonlinear: exp(-x^2)! )
+
+          x(:) = litterhum_daily(:)/moistlimit(:)
+          fireindex_daily(:,j) = EXP( - pi * x(:) * x(:) )
+
+       ELSEWHERE
+
+          fireindex_daily(:,j) = zero
+
+       ENDWHERE
+
+       !
+       ! 2.3 increase long-term fire index (mean probability)
+       !
+
+       fireindex(:,j) = ((tau_fire - dt) * fireindex(:,j) + (dt) * fireindex_daily(:,j)) / tau_fire
+
+       !
+       ! 2.4 litter influences fire intensity.
+       !     We use longer-term litter to be consistent with the fire index.
+       !
+
+       firelitter(:,j) = &
+            ( ( tau_fire-dt ) * firelitter(:,j) + dt * litter_above(:) ) / tau_fire
+
+
+       !
+       ! 3 Calculate fire fraction from litter and fireindex (i.e. basically drought)
+
+       !
+       ! 3.1 natural ground
+       !
+
+       !     This formulation has been developped for annual fire indices!
+       !     original form: firefrac(i) = fireindex(i) * EXP( f(fireindex(i)) )
+       !     Transform into daily fire fraction.
+
+       ! annual fire fraction
+
+       aff(:) = firefrac_func (npts, fireindex(:,j))
+
+       ! transform from annual fraction to daily fraction. 
+       ! annual fire fraction = 1. - (fraction of tree that survives each day) ** 365 =
+       !                      = 1. - ( 1. - daily fire fraction )**365
+       ! Thus, daily fire fraction = 1. - ( 1. - annual fire fraction )**(1/365)
+       ! If annual firefrac<<1, then firefrac_daily = firefrac * dt/one_year
+       ! This approximation avoids numerical problems.
+
+       IF(.NOT.disable_fire.AND.natural(j))THEN
+          WHERE ( aff(:) .GT. 0.1 )
+             firefrac(:,j) = un - ( un - aff(:) ) ** (dt/one_year)
+          ELSEWHERE
+             firefrac(:,j) = aff(:) * dt/one_year
+          ENDWHERE
+       ELSE
+          firefrac(:,j) = zero
+       ENDIF
+
+       ! No fire if litter is below critical value
+
+       WHERE ( firelitter(:,j) .LT. litter_crit )
+          firefrac(:,j) = zero
+       ENDWHERE
+
+       ! However, there is a minimum fire extent
+
+       firefrac(:,j) = MAX( 0.001_r_std * dt/one_year, firefrac(:,j) )
+
+       ! if FIRE_DISABLE flag is set no fire
+       IF (disable_fire) firefrac=0
+       !
+       ! 3.2 agricultural ground: no fire for the moment
+       !
+
+       IF ( .NOT. natural(j)) firefrac(:,j) = zero
+
+       !
+       ! 4 Determine fire impact: calculate fire disturbance for each PFT
+       !
+
+       !
+       ! 4.1 are we talking about a natural or an agricultural PFT?
+       !
+
+       !
+       ! 4.2 fire disturbance
+       !
+
+       IF ( tree(j) ) THEN
+
+          ! 4.2.1 Trees: always disturbed
+
+          fire_disturb(:) = ( un - resist(j) ) * firefrac(:,j)
+
+       ELSE
+
+          ! 4.2.2 Grasses are not disturbed if they are not in their growing season
+
+          WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
+
+             fire_disturb(:) = ( un - resist(j) ) * firefrac(:,j)
+
+          ELSEWHERE
+
+             fire_disturb(:) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+       !
+       ! 4.3 litter and co2 created through fire on living biomass
+       !
+
+       ! biomass can go into litter or atmosphere, depending on what plant compartment
+       ! we are talking about.
+
+       DO k = 1, nparts
+
+          ! grass roots and reserve survive.
+
+          IF ( .NOT. ( ( .NOT. tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres ) ) ) ) THEN
+
+             ! 4.3.1 A fraction goes directly into the atmosphere.
+             !       CO2 flux in gC/m**2 of total ground/day.
+             !NV passe en 2D            
+             co2_fire(:,j) =  co2_fire(:,j)+ biomass(:,j,k) * fire_disturb(:) * co2frac(k) / dt
+
+             ! 4.3.2 Determine the residue, in gC/m**2 of ground.
+
+             residue(:) = biomass(:,j,k) * fire_disturb(:) * ( un - co2frac(k) )
+             !MM in SZ ???        residue(:) = fire_disturb(:) * ( un - co2frac(k) )
+
+             ! 4.3.2.1 determine fraction of black carbon. Only for plant parts above the
+             !         ground, i.e. when co2_frac > 0.
+             !         A small part of the residue, which can be expressed as a function of
+             !         the fraction of volatilized carbon (assimilated to co2frac here),
+             !         becomes black carbon, and thus withdrawn from the soil carbon cycle (added
+             !         to the "geologic carbon cycle we don't care about here).
+             !         [Kuhlbusch et al. JGR 101, 23651-23665, 1996; Kuhlbusch & Crutzen, GBC 9,
+             !          491-501, 1995].
+
+             !             IF ( co2frac(k) .GT. min_stomate ) THEN
+             IF ( co2frac(k) .GT. zero ) THEN
+                bcfrac(:) = .3 / ( 1.3 ** ( 88.2 - 100.*co2frac(k) ) + 1. )
+             ELSE
+                bcfrac(:) = zero
+             ENDIF
+
+             ! 4.3.2.2 Add this fraction of the residue to the black carbon "reservoir", in
+             !         gC/(m**2 of total ground).
+
+             black_carbon(:) = &
+                  black_carbon(:) + bcfrac(:) * residue(:)
+             !MM in SZ                  black_carbon(:) + bcfrac(:) * residue(:) * biomass(:,j,k) 
+
+             ! 4.3.2.3 The rest (largest part) of the residue becomes litter.
+             bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + residue(:) * ( 1 - bcfrac(:) )
+             !MM in SZ   bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + residue(:) * ( 1 - bcfrac(:) ) * biomass(:,j,k) 
+          ENDIF  ! not for grass roots
+
+       ENDDO
+
+       !
+       ! 4.4 new vegetation characteristics
+       !
+
+       ! 4.4.1 decrease biomass per m**2 of ground
+       !       except for grass roots.
+
+       DO k = 1, nparts
+
+          IF ( .NOT. ( ( .NOT. tree(j) ) .AND. ( ( k.EQ.iroot ) .OR. ( k.EQ.icarbres) ) ) ) THEN
+
+             biomass(:,j,k) = ( un - fire_disturb(:) ) * biomass(:,j,k)
+
+          ENDIF
+
+       ENDDO
+
+       ! 4.4.2 If vegetation is dynamic, then decrease the density of tree
+       !       individuals.
+
+       IF ( control%ok_dgvm .AND. tree(j) ) THEN
+
+          ! fraction of plants that dies each day.
+          ! exact formulation: 1. - (1.-fire_disturb(:)) ** (1./dt)
+          firedeath(:,j) = fire_disturb(:) / dt
+
+          ind(:,j) = ( un - fire_disturb(:) ) * ind(:,j)
+
+       ENDIF
+
+    ENDDO      ! loop over PFTs
+
+    !
+    ! 5 A fraction of the litter is burned by the fire
+    !
+
+    DO j = 2,nvm
+
+       !
+       ! 5.1 exposed metabolic litter burns totally and goes directly into the atmosphere as
+       !     CO2.
+       !
+
+       ! 5.1.1 CO2 flux, in gC/(m**2 of total ground)/day.
+
+       co2_fire(:,j) = co2_fire(:,j) + litter(:,imetabolic,j,iabove) * &
+            firefrac(:,j) / dt
+
+       ! 5.1.2 decrease metabolic litter
+
+       litter(:,imetabolic,j,iabove) = litter(:,imetabolic,j,iabove) * &
+            ( un - firefrac(:,j) )
+
+       !
+       ! 5.2 exposed structural litter is not totally transformed into CO2.
+       !
+
+       ! 5.2.1 Fraction of exposed structural litter that does not
+       !       burn totally should depend on lignin content (lignin_struc). VERY TENTATIVE!
+
+       struc_residual(:) = 0.5 * lignin_struc(:,j,iabove)
+
+       ! 5.2.2 CO2 flux, in gC/(m**2 of total ground)/day.
+
+       co2_fire(:,j) = co2_fire(:,j) + &
+            litter(:,istructural,j,iabove) * firefrac(:,j) * &
+            ( un - struc_residual(:) )/ dt
+
+       ! 5.2.3 determine residue (litter that undergoes fire, but is not transformed
+       !       into CO2)
+
+       residue(:) = litter(:,istructural,j,iabove) * firefrac(:,j) * &
+            struc_residual(:)
+       !MM in SZ        residue(:) = firefrac(:,j) * struc_residual(:)
+
+       ! 5.2.4 determine fraction of black carbon in the residue.
+       !       depends on volatilized fraction of carbon (see 4.3.2.1)
+
+       bcfrac(:) = .3 / ( 1.3 ** ( 88.2 - 100.*(1.-struc_residual(:)) ) + 1. )
+
+       ! 5.2.5 Add this fraction of the residue to the black carbon "reservoir", in
+       !       gC/(m**2 of total ground).
+
+       black_carbon(:) = &
+            black_carbon(:) + bcfrac(:) * residue(:)
+       !MM in SZ             black_carbon(:) + bcfrac(:) * residue(:) * litter(:,iwoody,j,iabove) 
+
+       ! 5.2.6 The rest (largest part) of the residue remains litter. Remaining litter
+       !       is the sum of this and of the litter which has not undergone a fire.
+
+       litter(:,istructural,j,iabove) = &
+            litter(:,istructural,j,iabove) * ( un - firefrac(:,j) ) + &
+            residue(:) * ( un - bcfrac(:) )
+       !MM in SZ            residue(:) * ( un - bcfrac(:) ) * litter(:,iwoody,j,iabove)
+
+    ENDDO  !  ground
+
+    !
+    ! 5.3 diagnose fraction of leaves burned.
+    !     exposed leaves are burned entirely, even their structural part
+    !
+
+    DO j = 2,nvm
+
+       DO k = 1, nlitt
+          dead_leaves(:,j,k) = dead_leaves(:,j,k) * ( un - firefrac(:,j) )
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 6 history
+    !
+
+    ! output in 1/day
+    firefrac(:,:) = firefrac(:,:) / dt
+
+    CALL histwrite (hist_id_stomate, 'FIREFRAC', itime, &
+         firefrac(:,:), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'FIREDEATH', itime, &
+         firedeath(:,:), npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving fire'
+
+  END SUBROUTINE fire
+
+  FUNCTION firefrac_func (npts, x) RESULT (firefrac_result)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                             :: npts
+    ! fire index
+    REAL(r_std), DIMENSION(npts), INTENT(in)                         :: x
+
+    ! 0.2 result
+
+    ! fire fraction
+    REAL(r_std), DIMENSION(npts)                                     :: firefrac_result
+
+    ! 0.3 local
+
+    ! intermediate variable
+    REAL(r_std), DIMENSION(npts)                                     :: xm1
+
+    xm1(:) = x(:) - 1.
+
+    firefrac_result(:) = &
+         x(:) * EXP( xm1(:) / ( -.13*xm1(:)*xm1(:)*xm1(:) + .6*xm1(:)*xm1(:) + .8*xm1(:) + .45 ) )
+
+  END FUNCTION firefrac_func
+
+END MODULE lpj_fire
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_gap.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_gap.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_gap.f90	(revision 55)
@@ -0,0 +1,241 @@
+! gap routine - place for new plants
+!
+! Death rate of trees is estimated by evaluating their vigour (based on npp).
+! For large availabilities, lifetime is 50 years (!?).
+! Age of stands is not considered, although availability death rate should probably
+! depend on age.
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_gap.f90,v 1.10 2009/01/06 15:01:25 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_gap
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+  USE parallel
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC gap,gap_clear
+
+  ! first call
+  LOGICAL, SAVE                                           :: firstcall = .TRUE.
+
+CONTAINS
+
+
+  SUBROUTINE gap_clear
+    firstcall = .TRUE.
+  END SUBROUTINE gap_clear
+
+  SUBROUTINE gap (npts, dt, &
+       npp_longterm, turnover_longterm, lm_lastyearmax, &
+       PFTpresent, biomass, ind, bm_to_litter)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                     :: npts
+    ! Time step (days)
+    REAL(r_std), INTENT(in)                                  :: dt
+    ! "long term" net primary productivity (gC/(m**2 of ground)/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: npp_longterm
+    ! "long term" turnover rate (gC/(m**2 of ground)/year)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)     :: turnover_longterm
+    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: lm_lastyearmax
+
+    ! 0.2 modified fields
+
+    ! Is pft there
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)            :: PFTpresent
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)  :: biomass
+    ! Number of individuals / (m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)         :: ind
+    ! biomass taken away (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)  :: bm_to_litter
+
+    ! 0.3 local
+
+    ! which kind of mortality
+    LOGICAL, SAVE                                           :: constant_mortality
+    ! biomass increase
+    REAL(r_std), DIMENSION(npts)                             :: delta_biomass
+    ! vigour
+    REAL(r_std), DIMENSION(npts)                             :: vigour
+    ! natural availability, based on vigour
+    REAL(r_std), DIMENSION(npts)                             :: availability
+    ! mortality (fraction of trees that is dying per time step), per day in history file
+    REAL(r_std), DIMENSION(npts,nvm)                        :: mortality
+    ! indices
+    INTEGER(i_std)                                           :: j,k
+
+    ! =========================================================================
+
+    IF ( firstcall ) THEN
+
+       firstcall = .FALSE.
+
+       !Config  Key  = LPJ_GAP_CONST_MORT
+       !Config  Desc = constant tree mortality
+       !Config  Def  = y
+       !Config  Help = If yes, then a constant mortality is applied to trees. 
+       !Config         Otherwise, mortality is a function of the trees' 
+       !Config         vigour (as in LPJ).
+
+       constant_mortality = .TRUE.
+       CALL getin_p('LPJ_GAP_CONST_MORT', constant_mortality)     
+       WRITE(numout,*) 'gap: constant mortality:', constant_mortality
+
+    ENDIF
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering gap'
+
+    mortality(:,:) = zero
+
+    DO j = 2,nvm
+
+       ! only trees
+
+       IF ( tree(j) ) THEN
+
+          !
+          ! 1 determine availability
+          !
+
+          IF ( .NOT. constant_mortality ) THEN
+
+             !
+             ! 1.1 original formulation: mortality depends on vigour
+             !
+
+             WHERE ( PFTpresent(:,j) .AND. ( lm_lastyearmax(:,j) .GT. min_stomate ) )
+
+                ! how much did the tree grow per year?
+
+                delta_biomass(:) = &
+                     MAX( npp_longterm(:,j) - ( turnover_longterm(:,j,ileaf) + &
+                     turnover_longterm(:,j,iroot) + turnover_longterm(:,j,ifruit) ), &
+                     0._r_std )
+
+                ! scale this to the leaf surface of the tree
+
+                vigour(:) = delta_biomass(:) / (lm_lastyearmax(:,j)*sla(j)) / 70.
+
+             ELSEWHERE
+
+                vigour(:) = 0.0
+
+             ENDWHERE
+
+             WHERE ( PFTpresent(:,j) )
+
+                ! note that availability is never above 0.02, i.e. lifetime of 50 years when very
+                ! low vigour.
+
+                availability(:) = 0.02 / ( 1.+vigour(:)/0.17 )
+
+                ! Mortality (fraction per time step).
+                ! In the original DGVM, mortality was set to zero if there was strong fire
+                ! perturbation.
+                ! This has been de-activated since the npp is not influenced by fire,
+                ! as opposed to the original DGVM. Instead, mortality is simply
+                ! equal to the availability, modulated by the time step.
+                ! Exact formulation: mor = 1. - ( 1. - availability ) ** (dt/one_year)
+                ! approximation ok as availability < 0.02 << 1
+
+                mortality(:,j) = availability(:) * dt/one_year
+
+             ENDWHERE
+
+          ELSE
+
+             !
+             ! 1.2 Alternative version: Constant mortality
+             !
+
+             WHERE ( PFTpresent(:,j) )
+
+                mortality(:,j) = dt/(residence_time(j)*one_year)
+
+             ENDWHERE
+
+          ENDIF
+
+          !
+          ! 2 Special for the DGVM:
+          !   mortality is one if npp is zero or negative.
+          !
+
+          IF ( control%ok_dgvm ) THEN
+
+             WHERE ( PFTpresent(:,j) .AND. ( npp_longterm(:,j) .LE. min_stomate ) )
+
+                mortality(:,j) = 1.
+
+             ENDWHERE
+
+          ENDIF
+
+          !
+          ! 3 update biomass, create litter
+          !
+
+          DO k = 1, nparts
+
+             WHERE ( PFTpresent(:,j) )
+
+                bm_to_litter(:,j,k) = bm_to_litter(:,j,k) + mortality(:,j) * biomass(:,j,k)
+
+                biomass(:,j,k) = biomass(:,j,k) * ( un - mortality(:,j) )
+
+             ENDWHERE
+
+          ENDDO
+
+          !
+          ! 4 update number of individuals
+          !
+
+          IF ( control%ok_dgvm ) THEN
+
+             WHERE ( PFTpresent(:,j) )
+
+                ind(:,j) = ind(:,j) * ( un - mortality(:,j) )
+
+             ENDWHERE
+
+          ENDIF
+
+       ENDIF       ! only trees
+
+    ENDDO         ! loop over pfts
+
+    !
+    ! 5 history
+    !
+
+    ! output in fraction of trees that dies/day.
+    ! exact formulation: 1. - ( 1. - mortality ) ** (1./dt)
+    mortality = mortality / dt
+
+    CALL histwrite (hist_id_stomate, 'MORTALITY', itime, &
+         mortality, npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving gap'
+
+  END SUBROUTINE gap
+
+END MODULE lpj_gap
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_kill.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_kill.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_kill.f90	(revision 55)
@@ -0,0 +1,182 @@
+! kills pfts that obviously fare badly
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_kill.f90,v 1.8 2009/01/06 15:01:25 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_kill
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC kill
+
+CONTAINS
+
+  SUBROUTINE kill (npts, whichroutine, lm_lastyearmax, &
+       ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+       lai, age, leaf_age, leaf_frac, &
+       when_growthinit, everywhere, veget, veget_max, bm_to_litter)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                       :: npts
+    ! message
+    CHARACTER*10, INTENT(in)                                  :: whichroutine
+    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lm_lastyearmax
+
+    ! 0.2 modified fields
+
+    ! Number of individuals / m**2
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind
+    ! Is pft there
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: PFTpresent
+    ! crown area of individuals (m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: cn_ind
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)    :: biomass
+    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: senescence
+    ! How much time ago was the PFT eliminated for the last time (y)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: RIP_time
+    ! leaf area index OF AN INDIVIDUAL PLANT
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: lai
+    ! mean age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age
+    ! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: when_growthinit
+    ! is the PFT everywhere in the grid box or very localized (after its introduction)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: everywhere
+    ! fractional coverage on ground, taking into
+    !   account LAI (=grid-scale fpc)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max
+    ! conversion of biomass to litter (gC/(m**2 of ground)) / day
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)    :: bm_to_litter
+
+    ! 0.3 local
+
+    ! indices
+    INTEGER(i_std)                                             :: j,m
+    ! bookkeeping
+    LOGICAL, DIMENSION(npts)                                  :: was_killed
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering kill'
+
+    DO j = 2,nvm
+
+       was_killed(:) = .FALSE.
+
+       ! only kill natural PFTs
+
+       IF ( natural(j) ) THEN
+
+          ! kill present plants if number of individuals or last year's leaf
+          ! mass is close to zero.
+          ! the "was_killed" business is necessary for a more efficient code on the VPP
+
+          WHERE ( PFTpresent(:,j) .AND. &
+               ( ( ind(:,j) .LT. min_stomate ) .OR. &
+               ( lm_lastyearmax(:,j) .LT. min_stomate ) ) )
+
+             was_killed(:) = .TRUE.
+
+          ENDWHERE
+
+          IF ( ANY( was_killed(:) ) ) THEN
+
+             WHERE ( was_killed(:) )
+
+                ind(:,j) = zero
+
+                bm_to_litter(:,j,ileaf) = bm_to_litter(:,j,ileaf) + biomass(:,j,ileaf)
+                bm_to_litter(:,j,isapabove) = bm_to_litter(:,j,isapabove) + biomass(:,j,isapabove)
+                bm_to_litter(:,j,isapbelow) = bm_to_litter(:,j,isapbelow) + biomass(:,j,isapbelow)
+                bm_to_litter(:,j,iheartabove) = bm_to_litter(:,j,iheartabove) + &
+                     biomass(:,j,iheartabove)
+                bm_to_litter(:,j,iheartbelow) = bm_to_litter(:,j,iheartbelow) + &
+                     biomass(:,j,iheartbelow)
+                bm_to_litter(:,j,iroot) = bm_to_litter(:,j,iroot) + biomass(:,j,iroot)
+                bm_to_litter(:,j,ifruit) = bm_to_litter(:,j,ifruit) + biomass(:,j,ifruit)
+                bm_to_litter(:,j,icarbres) = bm_to_litter(:,j,icarbres) + biomass(:,j,icarbres)
+
+                biomass(:,j,ileaf) = zero
+                biomass(:,j,isapabove) = zero
+                biomass(:,j,isapbelow) = zero
+                biomass(:,j,iheartabove) = zero
+                biomass(:,j,iheartbelow) = zero
+                biomass(:,j,iroot) = zero
+                biomass(:,j,ifruit) = zero
+                biomass(:,j,icarbres) = zero
+
+                PFTpresent(:,j) = .FALSE.
+
+                cn_ind(:,j) = zero
+
+                senescence(:,j) = .FALSE.
+
+
+                age(:,j) = zero
+
+                when_growthinit(:,j) = undef
+
+                everywhere(:,j) = zero
+
+                veget(:,j) = zero
+
+                veget_max(:,j) = zero
+
+                RIP_time(:,j) = zero
+
+             ENDWHERE   ! number of individuals very low
+
+             DO m = 1, nleafages
+
+                WHERE ( was_killed(:) )
+
+                   leaf_age(:,j,m) = zero 
+                   leaf_frac(:,j,m) = zero 
+
+                ENDWHERE
+
+             ENDDO
+
+             IF ( bavard .GE. 2 ) THEN
+
+                WRITE(numout,*) 'kill: eliminated ',PFT_name(j)
+                WRITE(numout,*) '  at ',COUNT( was_killed(:) ),' points after '//whichroutine
+
+             ENDIF
+
+          ENDIF     ! PFT must be killed at at least one place
+
+       ENDIF       ! PFT is natural
+
+    ENDDO         ! loop over PFTs
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving kill'
+
+  END SUBROUTINE kill
+
+END MODULE lpj_kill
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_light.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_light.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_light.f90	(revision 55)
@@ -0,0 +1,521 @@
+! Light competition
+!
+! If canopy is almost closed (fpc > fpc_crit), then trees outcompete grasses.
+! fpc_crit is normally fpc_crit.
+! Here, fpc ("foilage protected cover") also takes into account the minimum fraction
+! of space covered by trees through branches etc. This is done to prevent strong relative
+! changes of fpc from one day to another for deciduous trees at the beginning of their
+! growing season, which would yield to strong cutbacks (see 3.2.1.1.2)
+! No competition between woody pfts (height of individuals is not considered) !
+! Exception: when one woody pft is overwhelming (i.e. fpc > fpc_crit). In that
+! case, eliminate all other woody pfts and reduce dominant pft to fpc_crit.
+! Age of individuals is not considered. In reality, light competition would more
+! easily kill young individuals, thus increasing the mean age of the stand.
+! Exclude agricultural pfts from competition
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_light.f90,v 1.8 2009/01/06 15:01:25 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_light
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC light, light_clear
+
+  ! first call
+  LOGICAL, SAVE                                            :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE light_clear
+    firstcall=.TRUE.
+  END SUBROUTINE light_clear
+
+  SUBROUTINE light (npts, dt, &
+       PFTpresent, cn_ind, lai, maxfpc_lastyear, &
+       ind, biomass, veget_lastlight, bm_to_litter)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                      :: npts
+    ! Time step (days)
+    REAL(r_std), INTENT(in)                                   :: dt
+    ! Is pft there
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                :: PFTpresent
+    ! crown area of individuals (m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: cn_ind
+    ! leaf area index OF AN INDIVIDUAL PLANT
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: lai
+    ! last year's maximum fpc for each natural PFT, on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)             :: maxfpc_lastyear
+
+    ! 0.2 modified fields
+
+    ! Number of individuals / m2
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: ind
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)   :: biomass
+    ! Vegetation cover after last light competition
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: veget_lastlight
+    ! biomass taken away (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)   :: bm_to_litter
+
+    ! 0.3 local
+
+    ! maximum total number of grass individuals in a closed canopy
+    REAL(r_std), PARAMETER                                    :: grass_mercy = 0.01
+    ! minimum fraction of trees that survive even in a closed canopy
+    REAL(r_std), PARAMETER                                    :: tree_mercy = 0.01
+    ! for diagnosis of fpc increase, compare today's fpc to last year's maximum (T) or
+    !   to fpc of last time step (F)?
+    LOGICAL, PARAMETER                                       :: annual_increase = .TRUE.
+    ! index
+    INTEGER(i_std)                                            :: i,j
+    ! total natural fpc
+    REAL(r_std), DIMENSION(npts)                              :: sumfpc
+    ! total natural woody fpc
+    REAL(r_std)                                               :: sumfpc_wood
+    ! change in total woody fpc
+    REAL(r_std)                                               :: sumdelta_fpc_wood
+    ! maximum wood fpc
+    REAL(r_std)                                               :: maxfpc_wood
+    ! which woody pft is maximum
+    INTEGER(i_std)                                            :: optpft_wood
+    ! total natural grass fpc
+    REAL(r_std)                                               :: sumfpc_grass
+    ! this year's foliage protected cover on natural part of the grid cell
+    REAL(r_std), DIMENSION(npts,nvm)                         :: fpc_nat
+    ! fpc change within last year
+    REAL(r_std), DIMENSION(nvm)                              :: deltafpc
+    ! Relative change of number of individuals for trees
+    REAL(r_std)                                               :: reduct
+    ! Fraction of plants that survive
+    REAL(r_std), DIMENSION(nvm)                              :: survive
+    ! number of grass PFTs present in the grid box
+    INTEGER(i_std)                                            :: num_grass
+    ! New total grass fpc
+    REAL(r_std)                                               :: sumfpc_grass2
+    ! fraction of plants that dies each day (1/day)
+    REAL(r_std), DIMENSION(npts,nvm)                         :: light_death
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering light'
+
+    !
+    ! 1 first call
+    !
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'light:'
+
+       WRITE(numout,*) '   > Maximum total number of grass individuals in'
+       WRITE(numout,*) '       a closed canopy: ', grass_mercy
+
+       WRITE(numout,*) '   > Minimum fraction of trees that survive even in'
+       WRITE(numout,*) '       a closed canopy: ', tree_mercy
+
+       WRITE(numout,*) '   > For trees, minimum fraction of crown area covered'
+       WRITE(numout,*) '       (due to its branches etc.)', min_cover
+
+       WRITE(numout,*) '   > for diagnosis of fpc increase, compare today''s fpc'
+       IF ( annual_increase ) THEN
+          WRITE(numout,*) '     to last year''s maximum.'
+       ELSE
+          WRITE(numout,*) '     to fpc of the last time step.'
+       ENDIF
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 2 fpc characteristics
+    !
+
+    !
+    ! 2.1 calculate fpc on natural part of grid cell.
+    !
+
+    DO j = 2, nvm
+
+       IF ( natural(j) ) THEN
+
+          ! 2.1.1 natural PFTs
+
+          IF ( tree(j) ) THEN
+
+             ! 2.1.1.1 trees: minimum cover due to stems, branches etc.
+
+             DO i = 1, npts
+                IF (lai(i,j) == val_exp) THEN
+                   fpc_nat(i,j) = cn_ind(i,j) * ind(i,j)
+                ELSE
+                   fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * &
+                        MAX( ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover )
+                ENDIF
+             ENDDO
+
+          ELSE
+
+             ! 2.1.1.2 bare ground 
+             IF (j == ibare_sechiba) THEN
+                fpc_nat(:,j) = cn_ind(:,j) * ind(:,j) 
+
+                ! 2.1.1.3 grasses
+             ELSE
+                DO i = 1, npts
+                   IF (lai(i,j) == val_exp) THEN
+                      fpc_nat(i,j) = cn_ind(i,j) * ind(i,j)
+                   ELSE
+                      fpc_nat(i,j) = cn_ind(i,j) * ind(i,j) * &
+                           ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) )
+                   ENDIF
+                ENDDO
+             ENDIF
+          ENDIF  ! tree/grass
+
+       ELSE
+
+          ! 2.1.2 agricultural PFTs: not present on natural part
+
+          fpc_nat(:,j) = zero
+
+       ENDIF    ! natural/agricultural
+
+    ENDDO
+
+    !
+    ! 2.2 sum natural fpc for every grid point
+    !
+
+    sumfpc(:) = zero
+    DO j = 2,nvm
+       !SZ bug correction MERGE: need to subtract agricultural area!
+       sumfpc(:) = sumfpc(:) + fpc_nat(:,j)
+    ENDDO
+
+    !
+    ! 3 Light competition
+    !
+
+    light_death(:,:) = zero
+
+    DO i = 1, npts ! SZ why this loop and not a vector statement ?
+
+       ! Only if vegetation cover is dense
+
+       IF ( sumfpc(i) .GT. fpc_crit ) THEN
+
+          ! fpc change for each pft
+          ! There are two possibilities: either we compare today's fpc with the fpc after the last
+          ! time step, or we compare it to last year's maximum fpc of that PFT. In the first case,
+          ! the fpc increase will be strong for seasonal PFTs at the beginning of the growing season.
+          ! As for trees, the cutback is proportional to this increase, this means that seasonal trees
+          ! will be disadvantaged compared to evergreen trees. In the original LPJ model, with its 
+          ! annual time step, the second method was used (this corresponds to annual_increase=.TRUE.)
+
+          IF ( annual_increase ) THEN
+             deltafpc(:) = MAX( (fpc_nat(i,:)-maxfpc_lastyear(i,:)), 0._r_std )
+          ELSE
+             deltafpc(:) = MAX( (fpc_nat(i,:)-veget_lastlight(i,:)), 0._r_std )
+          ENDIF
+
+          ! default: survive
+
+          survive(:) = 1.0
+
+          !
+          ! 3.1 determine some characteristics of the fpc distribution
+          !
+
+          sumfpc_wood = zero
+          sumdelta_fpc_wood = zero
+          maxfpc_wood = zero
+          optpft_wood = 0
+          sumfpc_grass = zero
+          num_grass = 0
+
+          DO j = 2,nvm
+
+             ! only natural pfts
+
+             IF ( natural(j) ) THEN
+
+                IF ( tree(j) ) THEN
+
+                   ! trees
+
+                   ! total woody fpc
+
+                   sumfpc_wood = sumfpc_wood + fpc_nat(i,j)
+
+                   ! how much did the woody fpc increase
+
+                   sumdelta_fpc_wood = sumdelta_fpc_wood + deltafpc(j)
+
+                   ! which woody pft is preponderant
+
+                   IF ( fpc_nat(i,j) .GT. maxfpc_wood ) THEN
+
+                      optpft_wood = j
+
+                      maxfpc_wood = fpc_nat(i,j)
+
+                   ENDIF
+
+                ELSE
+
+                   ! grasses
+
+                   ! total (natural) grass fpc
+
+                   sumfpc_grass = sumfpc_grass + fpc_nat(i,j)
+
+                   ! number of grass PFTs present in the grid box
+
+                   IF ( PFTpresent(i,j) ) THEN
+                      num_grass = num_grass + 1
+                   ENDIF
+
+                ENDIF   ! tree or grass
+
+             ENDIF   ! natural
+
+          ENDDO     ! loop over pfts
+
+          !
+          ! 3.2 light competition: assume wood outcompetes grass
+          !
+
+          IF (sumfpc_wood .GE. fpc_crit ) THEN
+
+             !
+             ! 3.2.1 all allowed natural space is covered by wood:
+             !       cut back trees to fpc_crit.
+             !       Original DGVM: kill grasses. Modified: we let a very
+             !       small fraction of grasses survive.
+             !
+
+             DO j = 2,nvm
+
+                ! only present and natural pfts compete
+
+                IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
+
+                   IF ( tree(j) ) THEN
+
+                      !
+                      ! 3.2.1.1 tree
+                      !
+
+                      IF ( maxfpc_wood .GE. fpc_crit ) THEN
+
+                         ! 3.2.1.1.1 one single woody pft is overwhelming
+
+                         IF ( j .eq. optpft_wood ) THEN
+
+                            ! reduction for this dominant pft
+
+                            reduct = un - fpc_crit / fpc_nat(i,j)
+
+                         ELSE
+
+                            ! strongly reduce all other woody pfts
+                            !   (original DGVM: tree_mercy = 0.0 )
+
+                            reduct = un - tree_mercy
+
+                         ENDIF   ! pft = dominant woody pft
+
+                      ELSE
+
+                         ! 3.2.1.1.2 no single woody pft is overwhelming
+                         !           (original DGVM: tree_mercy = 0.0 )
+                         !           The reduction rate is proportional to the ratio deltafpc/fpc.
+
+                         IF ( fpc_nat(i,j) .GE. min_stomate ) THEN
+
+                            reduct = MIN( ( ( deltafpc(j)/sumdelta_fpc_wood * &
+                                 (sumfpc_wood-fpc_crit) ) / fpc_nat(i,j) ), &
+                                 ( 1._r_std - tree_mercy ) )
+
+                         ELSE
+
+                            ! tree fpc didn't icrease or it started from nothing
+
+                            reduct = zero
+
+                         ENDIF
+
+                      ENDIF   ! maxfpc_wood > fpc_crit
+
+                      survive(j) = un - reduct
+
+                   ELSE
+
+                      !
+                      ! 3.2.1.2 grass: let a very small fraction survive (the sum of all
+                      !         grass individuals may make up a maximum cover of
+                      !         grass_mercy [for lai -> infinity]).
+                      !         In the original DGVM, grasses were killed in that case,
+                      !         corresponding to grass_mercy = 0.
+                      !
+
+                      survive(j) = ( grass_mercy / REAL( num_grass,r_std ) ) / ind(i,j)
+
+                      survive(j) = MIN( 1._r_std, survive(j) )
+
+                   ENDIF   ! tree or grass
+
+                ENDIF     ! pft there and natural
+
+             ENDDO       ! loop over pfts
+
+          ELSE
+
+             !
+             ! 3.2.2 not too much wood so that grasses can subsist
+             !
+
+             ! new total grass fpc
+             sumfpc_grass2 = fpc_crit - sumfpc_wood
+
+             DO j = 2,nvm
+
+                ! only present and natural PFTs compete
+
+                IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
+
+                   IF ( tree(j) ) THEN
+
+                      ! no change for trees
+
+                      survive(j) = 1.0
+
+                   ELSE
+
+                      ! grass: fractional loss is the same for all grasses
+
+                      IF ( sumfpc_grass .GT. min_stomate ) THEN
+                         survive(j) = sumfpc_grass2 / sumfpc_grass
+                      ELSE
+                         survive(j)=  zero
+                      ENDIF
+
+                   ENDIF
+
+                ENDIF    ! pft there and natural
+
+             ENDDO       ! loop over pfts
+
+          ENDIF    ! sumfpc_wood > fpc_crit
+
+          !
+          ! 3.3 update output variables
+          !
+
+          DO j = 2,nvm
+
+             IF ( PFTpresent(i,j) .AND. natural(j) ) THEN
+
+                bm_to_litter(i,j,:) = bm_to_litter(i,j,:) + &
+                     biomass(i,j,:) * ( un - survive(j) )
+
+                biomass(i,j,:) = biomass(i,j,:) * survive(j)
+
+                IF ( control%ok_dgvm ) THEN
+                   ind(i,j) = ind(i,j) * survive(j)
+                ENDIF
+
+                ! fraction of plants that dies each day. 
+                ! exact formulation: light_death(i,j) = un - survive(j) ** (1/dt)
+                light_death(i,j) = ( un - survive(j) ) / dt
+
+             ENDIF      ! pft there and natural
+
+          ENDDO        ! loop over pfts
+
+       ENDIF      ! sumfpc > fpc_crit
+
+    ENDDO        ! loop over grid points
+
+    !
+    ! 4 recalculate fpc on natural part of grid cell (for next light competition)
+    !
+
+    DO j = 2,nvm
+
+       IF ( natural(j) ) THEN
+
+          !
+          ! 4.1 natural PFTs
+          !
+
+          IF ( tree(j) ) THEN
+
+             ! 4.1.1 trees: minimum cover due to stems, branches etc.
+
+             DO i = 1, npts
+                IF (lai(i,j) == val_exp) THEN
+                   veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j) 
+                ELSE
+                   veget_lastlight(i,j) = &
+                        cn_ind(i,j) * ind(i,j) * &
+                        MAX( ( 1._r_std - exp( -lai(i,j) * ext_coeff(j) ) ), min_cover )
+                ENDIF
+             ENDDO
+
+          ELSE
+
+             ! 4.1.2 grasses
+             DO i = 1, npts
+                IF (lai(i,j) == val_exp) THEN
+                   veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j) 
+                ELSE
+                   veget_lastlight(i,j) = cn_ind(i,j) * ind(i,j) * &
+                        ( un - exp( -lai(i,j) * ext_coeff(j) ) )
+                ENDIF
+             ENDDO
+          ENDIF    ! tree/grass
+
+       ELSE
+
+          !
+          ! 4.2 agricultural PFTs: not present on natural part
+          !
+
+          veget_lastlight(:,j) = zero
+
+       ENDIF      ! natural/agricultural
+
+    ENDDO
+
+    !
+    ! 5 history
+    !
+
+    CALL histwrite (hist_id_stomate, 'LIGHT_DEATH', itime, &
+         light_death, npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving light'
+
+  END SUBROUTINE light
+
+END MODULE lpj_light
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_pftinout.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_pftinout.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/lpj_pftinout.f90	(revision 55)
@@ -0,0 +1,435 @@
+! throw out respectively introduce some PFTS
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/lpj_pftinout.f90,v 1.9 2010/04/06 15:44:01 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE lpj_pftinout
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC pftinout,pftinout_clear
+
+  ! first call
+  LOGICAL, SAVE                                             :: firstcall = .TRUE.
+
+CONTAINS
+
+
+  SUBROUTINE pftinout_clear
+    firstcall = .TRUE.
+  END SUBROUTINE pftinout_clear
+
+  SUBROUTINE pftinout (npts, dt, adapted, regenerate, &
+       neighbours, veget, veget_max, &
+       biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, &
+       PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, &
+       co2_to_bm, &
+       avail_tree, avail_grass)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                       :: npts
+    ! Time step (days)
+    REAL(r_std), INTENT(in)                                    :: dt
+    ! Winter not too cold
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: adapted
+    ! Winter sufficiently cold
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: regenerate
+    ! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    INTEGER(i_std), DIMENSION(npts,8), INTENT(in)              :: neighbours
+    ! fractional coverage on ground, taking into
+    !   account LAI (=grid-scale fpc)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: veget_max
+
+    ! 0.2 modified fields
+
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)    :: biomass
+    ! density of individuals 1/m**2
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: ind
+    ! mean age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: age
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac
+    ! "long term" net primary productivity (gC/(m**2 of ground)/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: npp_longterm
+    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: lm_lastyearmax
+    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
+    !         set to .FALSE. if PFT is introduced or killed
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: senescence
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: PFTpresent
+    ! is the PFT everywhere in the grid box or very localized (after its introduction)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: everywhere
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: when_growthinit
+    ! in order for this PFT to be introduced, does it have to be present in an
+    !   adjacent grid box?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: need_adjacent
+    ! How much time ago was the PFT eliminated for the last time (y)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)           :: RIP_time
+    ! biomass uptaken (gC/(m**2 of total ground)/day)
+    !NV passage 2D
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                :: co2_to_bm
+
+    ! 0.3 output
+
+    ! space availability for trees
+    REAL(r_std), DIMENSION(npts), INTENT(out)                  :: avail_tree
+    ! space availability for grasses
+    REAL(r_std), DIMENSION(npts), INTENT(out)                  :: avail_grass
+
+    ! 0.4 local
+
+    ! minimum availability
+    REAL(r_std), PARAMETER                                     :: min_avail = 0.01
+    ! availability
+    REAL(r_std), DIMENSION(npts)                               :: avail
+    ! indices
+    INTEGER(i_std)                                             :: i,j
+    ! total woody vegetation cover
+    REAL(r_std), DIMENSION(npts)                               :: sumfrac_wood
+    ! number of adjacent grid cells where PFT is ubiquitious
+    INTEGER(i_std), DIMENSION(npts)                            :: n_present
+    ! we can introduce this PFT
+    LOGICAL, DIMENSION(npts)                                  :: can_introduce
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering pftinout'
+
+    !
+    ! 1 Messages
+    !
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'pftinout: Minimum space availability: ', min_avail
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 2 Space availability
+    !
+
+    ! need to know total woody vegetation fraction
+
+    sumfrac_wood(:) = zero
+
+    DO j = 2,nvm
+
+       IF ( tree(j) ) THEN
+
+          sumfrac_wood(:) = sumfrac_wood(:) + veget(:,j)
+
+       ENDIF
+
+    ENDDO
+
+    avail_grass(:) = MAX( ( un - sumfrac_wood(:) ), min_avail )
+
+    avail_tree(:) = MAX( ( fpc_crit - sumfrac_wood(:) ), min_avail )
+
+    !
+    ! 3 Time since last elimination (y)
+    !
+
+    RIP_time = RIP_time + dt / one_year
+
+    !
+    ! 4 Agicultural PFTs: present if they are prescribed
+    !
+
+    DO j = 2,nvm
+
+       IF ( .NOT. natural(j) ) THEN
+
+          IF (bavard.GE.4) WRITE(numout,*) 'pftinout: Agricultural PFTs'
+
+          IF ( tree(j) ) THEN
+
+             !
+             ! 4.1 don't treat agricultural trees for the moment
+             !
+
+             WRITE(numout,*) 'pftinout: Agricultural trees not treated. We stop.'
+             STOP
+
+          ELSE
+
+             !
+             ! 4.2 grasses
+             !
+
+             DO i = 1, npts
+
+                IF ( ( veget_max(i,j) .GT. zero ) .AND. ( .NOT. PFTpresent(i,j) ) ) THEN
+
+                   ! prescribed, but not yet there.
+
+                   ind(i,j) = veget_max(i,j)
+
+                   biomass(i,j,:) = bm_sapl(j,:) * ind(i,j) /veget_max(i,j) ! TL
+                   !NV passge 2D
+
+                   co2_to_bm(i,j) =  co2_to_bm(i,j) +SUM( biomass(i,j,:) ) / dt
+
+                   PFTpresent(i,j) = .TRUE.
+
+                   everywhere(i,j) = un
+
+                   senescence(i,j) = .FALSE.
+
+                   age(i,j) = zero
+
+                ENDIF  ! prescribed, but PFT not yet present
+
+             ENDDO    ! loop over grid points
+
+          ENDIF
+
+       ENDIF      ! not natural
+
+    ENDDO        ! loop over PFTs
+
+    !
+    ! 5 Eliminate PFTs
+    !
+
+    DO j = 2,nvm
+
+       ! only for natural PFTs
+
+       IF ( natural(j) ) THEN
+
+          WHERE (  PFTpresent(:,j) .AND. ( adapted(:,j) .LT. adapted_crit ) )
+
+             ! PFT there, but not adapted any more (ex: winter too cold): kill
+             ! set number of individuals to zero - rest will be done in lpj_kill
+
+             ind(:,j) = zero
+
+          ENDWHERE
+
+       ENDIF    ! natural
+
+    ENDDO       ! loop over PFTs
+
+    !
+    ! 6 Introduce PFTs
+    !
+
+    DO j = 2,nvm
+
+       IF ( natural(j) ) THEN
+
+          ! space availability for this PFT
+
+          IF ( tree(j) ) THEN
+             avail(:) = avail_tree(:)
+          ELSE
+             avail(:) = avail_grass(:)
+          ENDIF
+
+          !
+          ! 6.1 Check if PFT not present but (adapted and regenerative)
+          !
+
+          can_introduce(:) = .FALSE.
+
+          DO i = 1, npts
+
+             IF ( .NOT. PFTpresent(i,j) .AND. &
+                  ( adapted(i,j) .GT. adapted_crit ) .AND. &
+                  ( regenerate(i,j) .GT. regenerate_crit )  ) THEN
+
+                ! climate allows introduction
+
+                IF ( need_adjacent(i,j) ) THEN
+
+                   ! 6.1.1 climate allows introduction, but we need to look at the neighbours
+                   !       If the PFT has totally invaded at least one adjacent
+                   !       grid cell, it can be introduced.
+
+                   ! count number of totally invaded neighbours
+                   ! no loop so that it can vectorize
+
+                   n_present(i) = 0
+
+                   IF ( neighbours(i,1) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,1),j) .GE. un-min_stomate ) THEN
+                         n_present(i) = n_present(i)+1
+                      ENDIF
+                   ENDIF
+                   IF ( neighbours(i,3) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,3),j) .GE. un-min_stomate ) THEN
+                         n_present(i) = n_present(i)+1
+                      ENDIF
+                   ENDIF
+                   IF ( neighbours(i,5) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,5),j) .GE. un-min_stomate ) THEN
+                         n_present(i) = n_present(i)+1
+                      ENDIF
+                   ENDIF
+                   IF ( neighbours(i,7) .GT. 0 ) THEN
+                      IF ( everywhere(neighbours(i,7),j) .GE. un-min_stomate ) THEN
+                         n_present(i) = n_present(i)+1
+                      ENDIF
+                   ENDIF
+
+                   IF ( n_present(i) .GT. 0 ) THEN
+
+                      ! PFT is ubiquitious in at least one adjacent grid box
+                      can_introduce(i) = .TRUE.
+
+                   ENDIF
+
+                ELSE
+
+                   ! 6.1.2 we don't have to look at neighbours
+
+                   can_introduce(i) = .TRUE.
+
+                ENDIF   ! do we have to look at the neighbours?
+
+             ENDIF     ! we'd like to introduce the PFT
+
+          ENDDO       ! loop over grid points 
+
+          !
+          ! 6.2 additionally test whether the PFT has been eliminated lately, i.e.
+          !     less than 1.25 years ago. Do not take full years as success of
+          !     introduction might depend on season.
+
+          WHERE ( RIP_time(:,j) .LT. 1.25 )
+
+             ! PFT was eliminated lately - cannot reintroduce
+
+             can_introduce(:) = .FALSE.
+
+          ENDWHERE
+
+          !
+          ! 6.3 Introduce that PFT where possible
+          !     "can_introduce" means that it either exists in neighbouring grid boxes 
+          !     or that we do not look at neighbours, that it has not been eliminated 
+          !     lately, and, of course, that the climate is good for that PFT.
+          !
+
+          WHERE ( can_introduce(:) )
+
+             PFTpresent(:,j) = .TRUE.
+
+             senescence(:,j) = .FALSE.
+
+             ! introduce at least a few saplings, even if canopy is closed
+
+             ind(:,j) = ind_0 * (dt/one_year) * avail(:)
+
+             WHERE(veget_max(:,j).GT.0)
+
+                biomass(:,j,ileaf) = bm_sapl(j,ileaf) * ind(:,j) /veget_max(:,j)
+                biomass(:,j,isapabove) = bm_sapl(j,isapabove) * ind(:,j) /veget_max(:,j)
+                biomass(:,j,isapbelow) = bm_sapl(j,isapbelow) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,iheartabove) = bm_sapl(j,iheartabove) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,iheartbelow) = bm_sapl(j,iheartbelow) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,iroot) = bm_sapl(j,iroot) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,ifruit) = bm_sapl(j,ifruit) * ind(:,j)/veget_max(:,j)
+                biomass(:,j,icarbres) = bm_sapl(j,icarbres) * ind(:,j)/veget_max(:,j)
+             ELSEWHERE
+
+                biomass(:,j,ileaf) = bm_sapl(j,ileaf) * ind(:,j)
+                biomass(:,j,isapabove) = bm_sapl(j,isapabove) * ind(:,j)
+                biomass(:,j,isapbelow) = bm_sapl(j,isapbelow) * ind(:,j)
+                biomass(:,j,iheartabove) = bm_sapl(j,iheartabove) * ind(:,j)
+                biomass(:,j,iheartbelow) = bm_sapl(j,iheartbelow) * ind(:,j)
+                biomass(:,j,iroot) = bm_sapl(j,iroot) * ind(:,j)
+                biomass(:,j,ifruit) = bm_sapl(j,ifruit) * ind(:,j)
+                biomass(:,j,icarbres) = bm_sapl(j,icarbres) * ind(:,j)
+             END WHERE
+             !NV passge 2D
+             co2_to_bm(:,j) = &
+                  co2_to_bm(:,j) / dt * &
+                  ( biomass(:,j,ileaf) + biomass(:,j,isapabove) + &
+                  biomass(:,j,isapbelow) + biomass(:,j,iheartabove) + &
+                  biomass(:,j,iheartbelow) + biomass(:,j,iroot) + &
+                  biomass(:,j,ifruit) + biomass(:,j,icarbres) )
+
+             when_growthinit(:,j) = large_value
+
+             age(:,j) = zero
+
+             ! all leaves are young
+             leaf_frac(:,j,1) = un
+
+             ! non-zero "long term" npp and last year's leaf mass for saplings -
+             !   so they won't be killed off by gap or kill
+
+             npp_longterm(:,j) = 10.
+
+             lm_lastyearmax(:,j) = bm_sapl(j,ileaf) * ind(:,j)
+
+          ENDWHERE    ! we can introduce the PFT
+
+          !
+          ! 6.4 expansion of the PFT within the grid box (not to be confused with areal
+          !     coverage)
+          !
+
+          IF ( treat_expansion ) THEN
+
+             WHERE ( can_introduce(:) )
+                ! low value at the beginning
+                everywhere(:,j) = 0.05
+             ENDWHERE
+
+          ELSE
+
+             ! expansion is not treated
+
+             WHERE ( can_introduce(:) )
+                everywhere(:,j) = un
+             ENDWHERE
+
+          ENDIF   ! treat expansion
+
+       ENDIF     ! only natural PFTs
+
+    ENDDO       ! loop over PFTs
+
+    !
+    ! 7 If a PFT has been present once in a grid box, we suppose that it will survive
+    !   in isolated places (e.g., an oasis) within that grid box, even if it gets
+    !   officially eliminated from it later. That means that if climate becomes favorable
+    !   again, it will not need to get seeds from adjacent grid cells.
+    !
+
+    WHERE ( PFTpresent )
+       need_adjacent = .FALSE.
+    ENDWHERE
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving pftinout'
+
+  END SUBROUTINE pftinout
+
+END MODULE lpj_pftinout
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate.f90	(revision 55)
@@ -0,0 +1,2895 @@
+!$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate.f90,v 1.41 2010/05/27 08:30:35 ssipsl Exp $
+!IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate
+  !---------------------------------------------------------------------
+  ! Daily update of leaf area index etc.
+  !---------------------------------------------------------------------
+  USE netcdf
+  !-
+  USE ioipsl
+  USE defprec
+  USE grid
+  USE constantes
+  USE constantes_veg
+  USE constantes_co2
+  USE stomate_constants
+  USE stomate_io
+  USE stomate_data
+  USE stomate_season
+  USE stomate_lpj
+  USE stomate_assimtemp
+  USE stomate_litter
+  USE stomate_vmax
+  USE stomate_soilcarbon
+  USE stomate_resp
+  USE parallel
+  !  USE Write_field_p
+  !-
+  IMPLICIT NONE
+  PRIVATE
+  PUBLIC stomate_main,stomate_clear
+  !
+  INTEGER,PARAMETER :: r_typ =nf90_real4
+  !-
+  ! variables used inside stomate module : declaration and initialisation
+  !-
+  ! total natural space (fraction of total space)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: veget_cov_max
+  ! new year total natural space (fraction of total space)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: veget_cov_max_new
+  ! carbon pool: active, slow, or passive, (gC/(m**2 of ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: carbon
+  ! density of individuals (1/(m**2 of ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: ind
+  ! daily moisture availability
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: humrel_daily
+  ! daily litter humidity
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: litterhum_daily
+  ! daily 2 meter temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_daily
+  ! daily minimum 2 meter temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_min_daily
+  ! daily surface temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: tsurf_daily
+  ! daily soil temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: tsoil_daily
+  ! daily soil humidity
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: soilhum_daily
+  ! daily precipitations (mm/day) (for phenology)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: precip_daily
+  ! daily gross primary productivity (gC/(m**2 of ground)/day)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gpp_daily
+  ! daily net primary productivity (gC/(m**2 of ground)/day)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: npp_daily
+  ! Turnover rates (gC/(m**2 of ground)/day)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: turnover_daily
+  ! Turnover rates (gC/(m**2 of ground)*dtradia)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)   :: turnover_littercalc
+  ! Probability of fire
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: fireindex
+  ! Longer term total litter above the ground (gC/m**2 of ground)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: firelitter
+  ! "monthly" moisture availability
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: humrel_month
+  ! "weekly" moisture availability
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: humrel_week
+  ! "long term" 2 meter temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_longterm
+  ! "long term" 2 meter reference temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: tlong_ref
+  ! "monthly" 2 meter temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_month
+  ! "weekly" 2 meter temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: t2m_week
+  ! "monthly" soil temperatures (K)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: tsoil_month
+  ! "monthly" soil humidity
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: soilhum_month
+  ! growing degree days, threshold -5 deg C (for phenology)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gdd_m5_dormance
+  ! growing degree days, since midwinter (for phenology)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gdd_midwinter
+  ! number of chilling days since leaves were lost (for phenology)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: ncd_dormance
+  ! number of growing days, threshold -5 deg C (for phenology)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: ngd_minus5
+  ! last year's maximum moisture availability
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxhumrel_lastyear
+  ! this year's maximum moisture availability
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxhumrel_thisyear
+  ! last year's minimum moisture availability
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: minhumrel_lastyear
+  ! this year's minimum moisture availability
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: minhumrel_thisyear
+  ! last year's maximum "weekly" GPP (gC/m**2 covered/day)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxgppweek_lastyear
+  ! this year's maximum "weekly" GPP (gC/m**2 covered/day)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxgppweek_thisyear
+  ! last year's annual GDD0
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: gdd0_lastyear
+  ! this year's annual GDD0
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: gdd0_thisyear
+  ! last year's annual precipitation (mm/year)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: precip_lastyear
+  ! this year's annual precipitation (mm/year)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: precip_thisyear
+  ! PFT exists (equivalent to veget > 0 for natural PFTs)
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:)        :: PFTpresent
+  ! "long term" net primary productivity (gC/(m**2 of ground)/year)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: npp_longterm
+  ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: lm_lastyearmax
+  ! this year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: lm_thisyearmax
+  ! last year's maximum fpc for each natural PFT, on ground
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxfpc_lastyear
+  ! this year's maximum fpc for each PFT, on ground (see stomate_season)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: maxfpc_thisyear
+  ! "long term" turnover rate (gC/(m**2 of ground)/year)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: turnover_longterm
+  ! "weekly" GPP (gC/day/(m**2 covered)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: gpp_week
+  ! biomass (gC/(m**2 of ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: biomass
+  ! is the plant senescent?
+  ! (only for deciduous trees - carbohydrate reserve)
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:)        :: senescence
+  ! how many days ago was the beginning of the growing season
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: when_growthinit
+  ! age (years). For trees, mean stand age.
+  ! For grasses, ears since introduction of PFT
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: age
+  ! Winter too cold? between 0 and 1
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: adapted
+  ! Winter sufficiently cold? between 0 and 1
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: regenerate
+  ! fraction of litter above the ground belonging to different PFTs
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: litterpart
+  ! metabolic and structural litter, above and below ground 
+  ! (gC/(m**2 of ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:):: litter
+  ! dead leaves on ground, per PFT, metabolic and structural,
+  ! in gC/(m**2 of ground)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: dead_leaves
+  ! black carbon on the ground (gC/(m**2 of total ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)      :: black_carbon
+  ! ratio Lignine/Carbon in structural litter, above and below ground, 
+  ! (gC/(m**2 of ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: lignin_struc
+  ! carbon emitted into the atmosphere by fire (living and dead biomass)
+  !   (in gC/m**2 of average ground/day)
+  !NV devient 2D
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)      :: co2_fire
+  ! co2 taken up (gC/(m**2 of total ground)/day)
+  !NV devient 2D
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)      :: co2_to_bm_dgvm
+  ! heterotrophic respiration (gC/day/m**2 of total ground)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_hetero_d
+  ! maintenance respiration (gC/day/(m**2 of total ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_hetero_radia
+  ! maintenance respiration (gC/day/(m**2 of total ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_maint_d
+  ! growth respiration (gC/day/(m**2 of total ground))
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: resp_growth_d
+  ! vegetation fractions (on ground) after last light competition
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: veget_lastlight
+  ! is the PFT everywhere in the grid box or very localized (after its intoduction)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: everywhere
+  ! in order for this PFT to be introduced,
+  ! does it have to be present in an adjacent grid box?
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:,:)       :: need_adjacent
+  ! leaf age (d)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: leaf_age
+  ! fraction of leaves in leaf age class
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: leaf_frac
+  ! How much time ago was the PFT eliminated for the last time (y)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: RIP_time
+  ! duration of dormance (d)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: time_lowgpp
+  ! time elapsed since strongest moisture availability (d)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: time_hum_min
+  ! minimum moisture during dormance
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: hum_min_dormance
+  ! time constant of probability of a leaf to be eaten by a herbivore (days)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)  :: herbivores
+  ! npp total written for forcesoil...
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)  :: npp_equil
+  ! npp total ...
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)  :: npp_tot
+  ! moisture control of heterotrophic respiration
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: control_moist
+  ! temperature control of heterotrophic respiration, above and below
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: control_temp
+  ! quantity of carbon going into carbon pools from litter decomposition
+  ! (gC/(m**2 of ground)/day)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:,:):: soilcarbon_input
+  ! quantity of carbon going into carbon pools from litter decomposition daily
+  ! (gC/(m**2 of ground)/day)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:):: soilcarbon_input_daily
+  ! moisture control of heterotrophic respiration daily
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)  :: control_moist_daily
+  ! temperature control of heterotrophic respiration, above and below daily
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:) :: control_temp_daily
+  ! how many states were calculated for a given soil forcing time step
+  ! turnover time of leaves
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)    :: turnover_time
+  ! daily total CO2 flux (gC/m**2/day)
+  !NV champs 2D
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)                   :: co2_flux_daily 
+  ! monthly total CO2 flux (gC/m**2)
+  !NV champs 2D
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)       :: co2_flux_monthly
+  ! conversion of biomass to litter (gC/(m**2 of ground))/day
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: bm_to_litter
+  ! conversion of biomass to litter (gC/(m**2 of ground))*dtradia
+  REAL(r_std), ALLOCATABLE,SAVE,DIMENSION(:,:,:)  :: bm_to_littercalc
+
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:)  :: nforce
+
+  ! Date and EndOfYear, intialize and update in slowproc
+  ! (Now managed in slowproc for land_use)
+  ! time step of STOMATE in days
+  REAL(r_std),SAVE                              :: dt_days=zero         ! Time step in days for stomate
+  ! to check
+  REAL(r_std),SAVE                              :: day_counter=zero     ! count each sechiba (dtradia) time step each day
+  ! date (d)
+  INTEGER(i_std),SAVE                          :: date=0
+  ! is it time for Stomate or update of LAI etc. ?
+  LOGICAL, SAVE                                :: do_slow=.FALSE.
+  ! Do update of yearly variables ?
+  ! This variable must be .TRUE. once a year
+  LOGICAL, SAVE                                :: EndOfYear=.FALSE.
+  ! Land cover change flag
+  LOGICAL,SAVE                                 :: lcchange=.FALSE.
+  ! Do update of monthly variables ?
+  ! This variable must be .TRUE. once a month
+  LOGICAL, SAVE                                :: EndOfMonth=.FALSE.
+  PUBLIC  dt_days, day_counter, date, do_slow, EndOfYear, lcchange
+
+
+  ! forcing data in memory
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: clay_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: humrel_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: litterhum_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: t2m_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: t2m_min_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: tsurf_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: tsoil_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: soilhum_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: precip_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: gpp_daily_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: resp_maint_part_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: veget_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: veget_max_fm
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: lai_fm
+
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: clay_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: humrel_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: litterhum_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: t2m_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: t2m_min_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: tsurf_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: tsoil_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: soilhum_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: precip_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: gpp_daily_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: resp_maint_part_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: veget_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: veget_max_fm_g
+  REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: lai_fm_g
+
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: isf
+  LOGICAL,ALLOCATABLE,SAVE,DIMENSION(:)      :: nf_written
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: nf_cumul
+  ! first call
+  LOGICAL,SAVE :: l_first_stomate = .TRUE.
+  ! flag for cumul of forcing if teststomate
+  LOGICAL,SAVE :: cumul_forcing=.FALSE.
+  ! flag for cumul of forcing if forcesoil
+  LOGICAL,SAVE :: cumul_Cforcing=.FALSE.
+  !
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: resp_maint_part_radia
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: resp_maint_part
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)   :: resp_maint_radia
+
+  ! Land cover change variables
+  ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
+  ! (10 or 100 + 1 : input from year of land cover change)
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)                         :: prod10
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)                         :: prod100
+  ! annual release from the 10/100 year-turnover pool compartments
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)                          :: flux10
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:,:)                          :: flux100
+  ! release during first year following land cover change
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)                            :: convflux
+  ! total annual release from the 10/100 year-turnover pool
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)                            :: cflux_prod10, cflux_prod100
+
+  ! harvest above ground biomass for agriculture
+  REAL(r_std),ALLOCATABLE,SAVE,DIMENSION(:)                            :: harvest_above
+
+CONTAINS
+  !
+  !=
+  !
+  SUBROUTINE stomate_main &
+       & (kjit, kjpij, kjpindex, dtradia, dt_slow, &
+       &  ldrestart_read, ldrestart_write, ldforcing_write, ldcarbon_write, &
+       &  index, lalo, neighbours, resolution, contfrac, totfrac_nobio, clay, &
+       &  t2m, t2m_min, temp_sol, stempdiag, &
+       &  humrel, shumdiag, litterhumdiag, precip_rain, precip_snow, &
+       &  gpp, deadleaf_cover, assim_param, &
+       &  lai, height, veget, veget_max, qsintmax, &
+       &  veget_max_new, totfrac_nobio_new, &
+       &  hist_id, hist2_id, rest_id_stom, hist_id_stom, hist_id_stom_IPCC, &
+       &  co2_flux,resp_maint,resp_hetero,resp_growth)
+    !---------------------------------------------------------------------
+    !
+    IMPLICIT NONE
+    ! 0 interface description
+    !
+    ! 0.1 input
+    !
+    ! 0.1.1 input scalar
+    !
+    ! Time step number
+    INTEGER(i_std),INTENT(in)                   :: kjit
+    ! Domain size
+    INTEGER(i_std),INTENT(in)                   :: kjpindex
+    ! Total size of the un-compressed grid
+    INTEGER(i_std),INTENT(in)                   :: kjpij
+    ! Time step of SECHIBA
+    REAL(r_std),INTENT(in)                    :: dtradia
+    ! Time step of STOMATE
+    REAL(r_std),INTENT(in)                    :: dt_slow
+    ! Logical for _restart_ file to read
+    LOGICAL,INTENT(in)                        :: ldrestart_read
+    ! Logical for _restart_ file to write
+    LOGICAL,INTENT(in)                        :: ldrestart_write
+    ! Logical for _forcing_ file to write
+    LOGICAL,INTENT(in)                        :: ldforcing_write
+    ! Logical for _carbon_forcing_ file to write
+    LOGICAL,INTENT(in)                        :: ldcarbon_write
+    ! SECHIBA's _history_ file identifier
+    INTEGER(i_std),INTENT(in)                   :: hist_id
+    ! SECHIBA's _history_ file 2 identifier
+    INTEGER(i_std),INTENT(in)                   :: hist2_id
+    ! STOMATE's _Restart_ file file identifier
+    INTEGER(i_std),INTENT(in)                   :: rest_id_stom
+    ! STOMATE's _history_ file file identifier
+    INTEGER(i_std),INTENT(in)                   :: hist_id_stom
+    ! STOMATE's IPCC _history_ file file identifier
+    INTEGER(i_std),INTENT(in)                   :: hist_id_stom_IPCC
+    !
+    ! 0.1.2 input fields
+    !
+    ! Indeces of the points on the map
+    INTEGER(i_std),DIMENSION(kjpindex),INTENT(in)  :: index
+    ! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std),DIMENSION(kjpindex,2),INTENT(in)     :: lalo
+    ! neighoring grid points if land
+    INTEGER(i_std),DIMENSION(kjpindex,8),INTENT(in) :: neighbours
+    ! size in x an y of the grid (m)
+    REAL(r_std),DIMENSION(kjpindex,2),INTENT(in)     :: resolution
+    ! fraction of continent in the grid
+    REAL(r_std),DIMENSION (kjpindex), INTENT (in)    :: contfrac
+    ! fraction of grid cell covered by lakes, land ice, cities, ...
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: totfrac_nobio
+    ! clay fraction
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: clay
+    ! Relative humidity ("moisture availability")
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in)   :: humrel
+    ! 2 m air temperature (K)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: t2m
+    ! min. 2 m air temp. during forcing time step (K)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: t2m_min
+    ! Surface temperature
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: temp_sol
+    ! Soil temperature
+    REAL(r_std),DIMENSION(kjpindex,nbdl),INTENT(in)  :: stempdiag
+    ! Relative soil moisture
+    REAL(r_std),DIMENSION(kjpindex,nbdl),INTENT(in)  :: shumdiag
+    ! Litter humidity
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: litterhumdiag
+    ! Rain precipitation
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: precip_rain
+    ! Snow precipitation
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: precip_snow
+    ! GPP (gC/(m**2 of total ground)/time step)
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in)   :: gpp
+    ! new "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    ! only if EndOfYear is activated
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in)  :: veget_max_new 
+    ! new fraction of grid cell covered by lakes, land ice, cities, ...
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)       :: totfrac_nobio_new
+    !
+    ! 0.2 output
+    !
+    ! 0.2.1 output scalar
+    !
+    ! 0.2.2 output fields
+    !
+    ! CO2 flux in gC/m**2 of average ground/dt
+    !NV champs 2D 
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out)      :: co2_flux
+    ! autotrophic respiration in gC/m**2 of surface/dt
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out)  :: resp_maint
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out)  :: resp_growth
+    !NV champs2D
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out)      :: resp_hetero
+    !
+    ! 0.3 modified
+    !
+    ! 0.3.1 modified scalar
+    ! 0.3.2 modified fields
+    !
+    ! Surface foliere
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout)  :: lai
+    ! Fraction of vegetation type from hydrological module. Takes into account ice etc.
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout)  :: veget
+    ! Maximum fraction of vegetation type from hydrological module. Takes into account ice etc.
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout)  :: veget_max
+    ! height (m)
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout)  :: height
+    ! min+max+opt temps & vmax for photosynthesis
+    REAL(r_std),DIMENSION(kjpindex,nvm,npco2),INTENT(inout)  :: assim_param
+    ! fraction of soil covered by dead leaves
+    REAL(r_std),DIMENSION(kjpindex),INTENT(inout)    :: deadleaf_cover
+    ! Maximum water on vegetation for interception
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(inout) :: qsintmax
+    !
+    ! 0.4 local declaration
+    !
+    ! 0.4.1 variables defined on nvm in SECHIBA, nvm in STOMATE/LPJ
+
+    ! gross primary productivity (gC/(m**2 of total ground)/day)
+    REAL(r_std),DIMENSION(kjpindex,nvm)             :: gpp_d
+    ! fractional coverage: actually covered space, taking into account LAI (= grid scale fpc).
+    ! Fraction of ground.
+    REAL(r_std),DIMENSION(kjpindex,nvm)             :: veget_cov
+
+    ! 0.4.2 other
+    !
+    ! soil level used for LAI
+    INTEGER(i_std),SAVE                          :: lcanop
+    ! counts time until next STOMATE time step
+    REAL(r_std)                                   :: day_counter_read
+    ! STOMATE time step read in restart file
+    REAL(r_std)                                   :: dt_days_read
+    ! STOMATE date
+    INTEGER(i_std)                               :: date_read
+    ! Maximum STOMATE time step (days)
+    REAL(r_std),PARAMETER                         :: max_dt_days = 5.
+    ! Writing frequency for history file (d)
+    REAL(r_std)                                   :: hist_days
+    ! precipitation (mm/day)
+    REAL(r_std),DIMENSION(kjpindex)               :: precip
+    ! Maximum rate of carboxylation
+    REAL(r_std),DIMENSION(kjpindex,nvm)          :: vcmax
+    ! Maximum rate of RUbp regeneration
+    REAL(r_std),DIMENSION(kjpindex,nvm)          :: vjmax
+    ! Min temperature for photosynthesis (deg C)
+    REAL(r_std),DIMENSION(kjpindex,nvm)          :: t_photo_min
+    ! Opt temperature for photosynthesis (deg C)
+    REAL(r_std),DIMENSION(kjpindex,nvm)          :: t_photo_opt
+    ! Max temperature for photosynthesis (deg C)
+    REAL(r_std),DIMENSION(kjpindex,nvm)          :: t_photo_max
+    !NV supprimé
+    ! total autotrophic respiration (gC/day/(m**2 of total ground))
+    !    REAL(r_std),DIMENSION(kjpindex)               :: resp_auto_tot
+    !NV gpp_tot supprimé
+    ! total photosynthesis (gC/day/(m**2 of total ground))
+    !    REAL(r_std),DIMENSION(kjpindex)               :: gpp_tot
+    ! -- LOOP
+    REAL(r_std)                                   :: net_co2_flux_monthly, net_co2_flux_monthly_sum
+    INTEGER                                       :: ios
+    ! for forcing file: "daily" gpp
+    REAL(r_std),DIMENSION(kjpindex,nvm)           :: gpp_daily_x
+    ! for forcing file: "daily" auto resp
+    REAL(r_std),DIMENSION(kjpindex,nvm,nparts)    :: resp_maint_part_x
+    ! total "vegetation" cover
+    REAL(r_std),DIMENSION(kjpindex)               :: cvegtot
+    INTEGER(i_std)                                :: ji, jv, i, j
+    REAL(r_std)                                   :: trans_veg
+    REAL(r_std)                                   :: tmp_day(1)
+    !
+
+    INTEGER(i_std)                               :: ier
+    ! moisture control of heterotrophic respiration
+    REAL(r_std),DIMENSION(kjpindex,nlevs)         :: control_moist_inst
+    ! temperature control of heterotrophic respiration, above and below
+    REAL(r_std),DIMENSION(kjpindex,nlevs)         :: control_temp_inst
+    ! quantity of carbon going into carbon pools from litter decomposition
+    ! (gC/(m**2 of ground)/day)
+    REAL(r_std),DIMENSION(kjpindex,ncarb,nvm)           :: soilcarbon_input_inst
+    ! time step of soil forcing file (in days)
+    REAL(r_std),SAVE            :: dt_forcesoil
+    INTEGER(i_std),SAVE        :: nparan            ! Number of time steps per year for carbon spinup
+    INTEGER(i_std),SAVE        :: nbyear
+    INTEGER(i_std),PARAMETER   :: nparanmax=36      ! Number max of time steps per year for carbon spinup
+    REAL(r_std)                 :: sf_time
+    INTEGER(i_std),SAVE        :: iatt=1
+    INTEGER(i_std),SAVE        :: iatt_old=1
+    INTEGER(i_std)             :: max_totsize, totsize_1step,totsize_tmp
+    REAL(r_std)                 :: xn
+    INTEGER(i_std),SAVE        :: nsfm, nsft
+    INTEGER(i_std),SAVE        :: iisf
+    !-
+    CHARACTER(LEN=100), SAVE    :: forcing_name,Cforcing_name
+    INTEGER(i_std),SAVE         :: Cforcing_id
+    INTEGER(i_std),PARAMETER    :: ndm = 10
+    INTEGER(i_std)              :: vid
+    INTEGER(i_std)              :: nneigh,direct
+    INTEGER(i_std),DIMENSION(ndm) :: d_id
+
+
+    ! root temperature (convolution of root and soil temperature profiles)
+    REAL(r_std),DIMENSION(kjpindex,nvm)            :: t_root
+    REAL(r_std),DIMENSION(kjpindex,nvm,nparts)     :: coeff_maint
+    ! temperature which is pertinent for maintenance respiration (K)
+    REAL(r_std),DIMENSION(kjpindex,nparts)          :: t_maint_radia
+    ! integration constant for root profile
+    REAL(r_std),DIMENSION(kjpindex)                 :: rpc
+    ! long term annual mean temperature, C
+    REAL(r_std),DIMENSION(kjpindex)                 :: tl
+    ! slope of maintenance respiration coefficient (1/K)
+    REAL(r_std),DIMENSION(kjpindex)                 :: slope
+    ! soil levels (m)
+    REAL(r_std),DIMENSION(0:nbdl)                   :: z_soil
+    ! root depth. This will, one day, be a prognostic variable.
+    ! It will be calculated by
+    ! STOMATE (save in restart file & give to hydrology module!),
+    ! probably somewhere
+    ! in the allocation routine. For the moment, it is prescribed.
+    REAL(r_std),DIMENSION(kjpindex,nvm)            :: rprof
+    INTEGER(i_std)                                 :: l,k
+    ! litter heterotrophic respiration (gC/day/m**2 by PFT)
+    REAL(r_std),DIMENSION(kjpindex,nvm)       :: resp_hetero_litter 
+    ! soil heterotrophic respiration (gC/day/m**2 by PFT)
+    REAL(r_std),DIMENSION(kjpindex,nvm)       :: resp_hetero_soil
+    INTEGER(i_std) :: iyear
+
+    REAL(r_std),DIMENSION(nbp_glo) :: clay_g
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:,:) :: soilcarbon_input_g
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: control_moist_g
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:,:)   :: control_temp_g
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:)     :: npp_equil_g
+
+    REAL(r_std), DIMENSION(kjpindex)                                   :: vartmp
+    !---------------------------------------------------------------------
+    ! first of all: store time step in common value
+    itime = kjit
+
+    z_soil(0) = zero
+    z_soil(1:nbdl) = diaglev(1:nbdl)
+    DO j=1,nvm
+       rprof(:,j) = 1./humcste(j)
+    ENDDO
+    !-
+    ! 1 do initialisation
+    !-
+    resp_growth=zero
+    IF (l_first_stomate) THEN
+       IF (long_print) THEN
+          WRITE (numout,*) ' l_first_stomate : call stomate_init'
+       ENDIF
+       !
+       ! 1.0 Initialization of constant tabs without bare_soil
+       !
+       CALL stomate_constants_init ()
+       !
+       ! 1.1 allocation, file definitions. Set flags.
+       !
+       CALL stomate_init (kjpij, kjpindex, index, ldforcing_write, lalo, &
+            rest_id_stom, hist_id_stom, hist_id_stom_IPCC)
+
+       co2_flux_monthly(:,:) = zero
+       !
+       ! 1.2 read PFT data
+       !
+       CALL data (kjpindex, lalo)
+       !
+       ! 1.3 Initial conditions
+       !
+       ! 1.3.1 read STOMATE's start file
+       !
+       CALL readstart &
+            &        (kjpindex, index, lalo, resolution, &
+            &         day_counter_read, dt_days_read, date_read, &
+            &         ind, adapted, regenerate, &
+            &         humrel_daily, litterhum_daily, &
+            &         t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
+            &         soilhum_daily, precip_daily, &
+            &         gpp_daily, npp_daily, turnover_daily, &
+            &         humrel_month, humrel_week, &
+            &         t2m_longterm, tlong_ref, t2m_month, t2m_week, &
+            &         tsoil_month, soilhum_month, fireindex, firelitter, &
+            &         maxhumrel_lastyear, maxhumrel_thisyear, &
+            &         minhumrel_lastyear, minhumrel_thisyear, &
+            &         maxgppweek_lastyear, maxgppweek_thisyear, &
+            &         gdd0_lastyear, gdd0_thisyear, &
+            &         precip_lastyear, precip_thisyear, &
+            &         gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+            &         PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
+            &         maxfpc_lastyear, maxfpc_thisyear, &
+            &         turnover_longterm, gpp_week, biomass, resp_maint_part, &
+            &         leaf_age, leaf_frac, &
+            &         senescence, when_growthinit, age, &
+            &         resp_hetero_d, resp_maint_d, resp_growth_d, co2_fire, co2_to_bm_dgvm, &
+            &         veget_lastlight, everywhere, need_adjacent, RIP_time, time_lowgpp, &
+            &         time_hum_min, hum_min_dormance, &
+            &         litterpart, litter, dead_leaves, &
+            &         carbon, black_carbon, lignin_struc,turnover_time,&
+            &         prod10,prod100,flux10, flux100, &
+            &         convflux, cflux_prod10, cflux_prod100, bm_to_litter)
+
+       ! 1.4 read the boundary conditions
+       !
+       CALL readbc (kjpindex, lalo, resolution, tlong_ref)
+       !
+       ! 1.5 check time step
+       !
+       ! 1.5.1 allow STOMATE's time step to change
+       !       although this is dangerous
+       !
+       IF (dt_days /= dt_days_read) THEN
+          WRITE(numout,*) 'slow_processes: STOMATE time step changes:', &
+               dt_days_read,' -> ',dt_days
+       ENDIF
+
+       ! 1.5.2 time step has to be a multiple of a full day
+
+       IF ( ( dt_days-REAL(NINT(dt_days),r_std) ) > min_stomate ) THEN
+          WRITE(numout,*) 'slow_processes: STOMATE time step is wrong:', &
+               &                    dt_days,' days.'
+          STOP
+       ENDIF
+
+       ! 1.5.3 upper limit to STOMATE's time step
+
+       IF ( dt_days > max_dt_days ) THEN
+          WRITE(numout,*) 'slow_processes: STOMATE time step too large:', &
+               &                    dt_days,' days.'
+          STOP
+       ENDIF
+
+       ! 1.5.4 STOMATE time step must not be less than the forcing time step
+
+       IF ( dtradia > dt_days*one_day ) THEN
+          WRITE(numout,*) &
+               &   'slow_processes: STOMATE time step smaller than forcing time step.'
+          STOP
+       ENDIF
+
+       ! 1.5.5 For teststomate : test day_counter
+       IF ( abs(day_counter - day_counter_read) > min_stomate ) THEN
+          WRITE(numout,*) 'slow_processes: STOMATE day counter changes:', &
+               day_counter_read,' -> ',day_counter
+       ENDIF
+
+       ! 1.5.6 date check
+       IF (date /= date_read) THEN
+          WRITE(numout,*) 'slow_processes: STOMATE date changes:', &
+               date_read,' -> ',date
+       ENDIF
+
+       ! 1.5.6 some more messages
+
+       WRITE(numout,*) 'slow_processes, STOMATE time step (d): ', dt_days
+
+       !
+       ! 1.6 write forcing file for stomate?
+       !
+       IF (ldforcing_write) THEN
+
+          !Config  Key  = STOMATE_FORCING_NAME
+          !Config  Desc = Name of STOMATE's forcing file
+          !Config  Def  = NONE
+          !Config  Help = Name that will be given
+          !Config         to STOMATE's offline forcing file
+          !-
+          forcing_name = stomate_forcing_name              ! compatibilité avec driver Nicolas
+          CALL getin_p('STOMATE_FORCING_NAME',forcing_name)
+
+          IF ( TRIM(forcing_name) /= 'NONE' ) THEN  
+             IF (is_root_prc) CALL SYSTEM ('rm -f '//TRIM(forcing_name))
+             WRITE(numout,*) 'writing a forcing file for STOMATE.'
+
+             !Config  Key  = STOMATE_FORCING_MEMSIZE
+             !Config  Desc = Size of STOMATE forcing data in memory (MB)
+             !Config  Def  = 50
+             !Config  Help = This variable determines how many
+             !Config         forcing states will be kept in memory.
+             !Config         Must be a compromise between memory
+             !Config         use and frequeny of disk access.
+
+             max_totsize = 50
+             CALL getin_p('STOMATE_FORCING_MEMSIZE', max_totsize)      
+             max_totsize = max_totsize*1000000
+
+             totsize_1step = &
+                  &      SIZE(clay)*KIND(clay) &
+                  &           +SIZE(humrel_daily)*KIND(humrel_daily) &
+                  &     +SIZE(litterhum_daily)*KIND(litterhum_daily) &
+                  &     +SIZE(t2m_daily)*KIND(t2m_daily) &
+                  &     +SIZE(t2m_min_daily)*KIND(t2m_min_daily) &
+                  &     +SIZE(tsurf_daily)*KIND(tsurf_daily) &
+                  &     +SIZE(tsoil_daily)*KIND(tsoil_daily) &
+                  &     +SIZE(soilhum_daily)*KIND(soilhum_daily) &
+                  &     +SIZE(precip_daily)*KIND(precip_daily) &
+                  &     +SIZE(gpp_daily_x)*KIND(gpp_daily_x) &
+                  &     +SIZE(resp_maint_part_x)*KIND(resp_maint_part_x) &
+                  &     +SIZE(veget)*KIND(veget) &
+                  &     +SIZE(veget_max)*KIND(veget_max) &
+                  &     +SIZE(lai)*KIND(lai)
+
+             CALL reduce_sum(totsize_1step,totsize_tmp)
+             CALL bcast(totsize_tmp)
+             totsize_1step=totsize_tmp 
+             ! total number of forcing steps
+             nsft = INT(one_year/(dt_slow/one_day))
+
+             ! number of forcing steps in memory
+             nsfm = MIN(nsft, &
+                  &       MAX(1,NINT( REAL(max_totsize,r_std) &
+                  &                  /REAL(totsize_1step,r_std))))
+
+             CALL init_forcing (kjpindex,nsfm,nsft)
+
+             isf(:) = (/ (i,i=1,nsfm) /)
+             nf_written(:) = .FALSE.
+             nf_cumul(:) = 0
+
+             iisf = 0
+
+             !-
+             IF (is_root_prc) THEN
+                ier = NF90_CREATE (TRIM(forcing_name),NF90_SHARE,forcing_id)
+                ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL,'dtradia',dtradia)
+                ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL,'dt_slow',dt_slow)
+                ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
+                     &                            'nsft',REAL(nsft,r_std))
+                ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
+                     &                            'kjpij',REAL(iim_g*jjm_g,r_std))
+                ier = NF90_PUT_ATT (forcing_id,NF90_GLOBAL, &
+                     &                            'kjpindex',REAL(nbp_glo,r_std))
+                !-
+                ier = NF90_DEF_DIM (forcing_id,'points',nbp_glo,d_id(1))
+                ier = NF90_DEF_DIM (forcing_id,'layers',nbdl,d_id(2))
+                ier = NF90_DEF_DIM (forcing_id,'pft',nvm,d_id(3))
+                direct=2
+                ier = NF90_DEF_DIM (forcing_id,'direction',direct,d_id(4))
+                nneigh=8
+                ier = NF90_DEF_DIM (forcing_id,'nneigh',nneigh,d_id(5))
+                ier = NF90_DEF_DIM (forcing_id,'time',nsft,d_id(6))
+                ier = NF90_DEF_DIM (forcing_id,'nbparts',nparts,d_id(7))
+                !-
+                ier = NF90_DEF_VAR (forcing_id,'points',    r_typ,d_id(1),vid)
+                ier = NF90_DEF_VAR (forcing_id,'layers',    r_typ,d_id(2),vid)
+                ier = NF90_DEF_VAR (forcing_id,'pft',       r_typ,d_id(3),vid)
+                ier = NF90_DEF_VAR (forcing_id,'direction', r_typ,d_id(4),vid)
+                ier = NF90_DEF_VAR (forcing_id,'nneigh',    r_typ,d_id(5),vid)
+                ier = NF90_DEF_VAR (forcing_id,'time',      r_typ,d_id(6),vid)
+                ier = NF90_DEF_VAR (forcing_id,'nbparts',   r_typ,d_id(7),vid)
+                ier = NF90_DEF_VAR (forcing_id,'index',     r_typ,d_id(1),vid)
+                ier = NF90_DEF_VAR (forcing_id,'contfrac',  r_typ,d_id(1),vid) 
+                ier = NF90_DEF_VAR (forcing_id,'lalo', &
+                     &                            r_typ,(/ d_id(1),d_id(4) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'neighbours', &
+                     &                            r_typ,(/ d_id(1),d_id(5) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'resolution', &
+                     &                            r_typ,(/ d_id(1),d_id(4) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'clay', &
+                     &                            r_typ,(/ d_id(1),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'humrel', &
+                     &                            r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'litterhum', &
+                     &                            r_typ,(/ d_id(1),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'t2m', &
+                     &                            r_typ,(/ d_id(1),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'t2m_min', &
+                     &                            r_typ,(/ d_id(1),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'tsurf', &
+                     &                            r_typ,(/ d_id(1),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'tsoil', &
+                     &                            r_typ,(/ d_id(1),d_id(2),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'soilhum', &
+                     &                            r_typ,(/ d_id(1),d_id(2),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'precip', &
+                     &                            r_typ,(/ d_id(1),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'gpp', &
+                     &                            r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'veget', &
+                     &                            r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'veget_max', &
+                     &                            r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'lai', &
+                     &                            r_typ,(/ d_id(1),d_id(3),d_id(6) /),vid)
+                ier = NF90_DEF_VAR (forcing_id,'resp_maint_part', &
+                     &                       r_typ,(/ d_id(1),d_id(3),d_id(7),d_id(6) /),vid)
+                ier = NF90_ENDDEF (forcing_id)
+                !-
+                ier = NF90_INQ_VARID (forcing_id,'points',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid, &
+                     &                            (/(REAL(i,r_std),i=1,nbp_glo) /))
+                ier = NF90_INQ_VARID (forcing_id,'layers',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nbdl)/))
+                ier = NF90_INQ_VARID (forcing_id,'pft',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nvm)/))
+                ier = NF90_INQ_VARID (forcing_id,'direction',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,2)/))
+                ier = NF90_INQ_VARID (forcing_id,'nneigh',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,8)/))
+                ier = NF90_INQ_VARID (forcing_id,'time',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nsft)/))
+                ier = NF90_INQ_VARID (forcing_id,'nbparts',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,(/(REAL(i,r_std),i=1,nparts)/))
+                ier = NF90_INQ_VARID (forcing_id,'index',vid)  
+                ier = NF90_PUT_VAR (forcing_id,vid,REAL(index_g,r_std))
+                ier = NF90_INQ_VARID (forcing_id,'contfrac',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,REAL(contfrac_g,r_std))
+                ier = NF90_INQ_VARID (forcing_id,'lalo',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,lalo_g)
+                !ym attention a neighbours, a modifier plus tard      
+                ier = NF90_INQ_VARID (forcing_id,'neighbours',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,REAL(neighbours_g,r_std))
+                ier = NF90_INQ_VARID (forcing_id,'resolution',vid)
+                ier = NF90_PUT_VAR (forcing_id,vid,resolution_g)
+             ENDIF
+          ENDIF
+       ENDIF
+       !
+       ! 1.7 write forcing file for the soil?
+       !
+       IF (ldcarbon_write) THEN
+          !
+          !Config  Key  = STOMATE_CFORCING_NAME
+          !Config  Desc = Name of STOMATE's carbon forcing file
+          !Config  Def  = NONE
+          !Config  Help = Name that will be given to STOMATE's carbon
+          !Config         offline forcing file
+          !-
+          Cforcing_name = stomate_Cforcing_name               ! compatibilité avec driver Nicolas
+          CALL getin_p('STOMATE_CFORCING_NAME',Cforcing_name)
+
+          IF ( TRIM(Cforcing_name) /= 'NONE' ) THEN  
+             IF (is_root_prc) CALL SYSTEM ('rm -f '//TRIM(Cforcing_name))
+             !
+             ! time step of forcesoil
+             !
+             !Config  Key  = FORCESOIL_STEP_PER_YEAR
+             !Config  Desc = Number of time steps per year for carbon spinup.
+             !Config  Def  = 12
+             !Config  Help = Number of time steps per year for carbon spinup.
+             nparan = 12
+             CALL getin_p('FORCESOIL_STEP_PER_YEAR', nparan)
+
+             IF ( nparan < 1 ) nparan = 1
+
+             !Config  Key  = FORCESOIL_NB_YEAR
+             !Config  Desc = Number of years saved for carbon spinup.
+             !Config         If internal parameter cumul_Cforcing is TRUE in stomate.f90
+             !config         Then this parameter is forced to one.
+             !Config  Def  = 1
+             !Config  Help = Number of years saved for carbon spinup.
+             nbyear=1
+             CALL getin_p('FORCESOIL_NB_YEAR', nbyear)
+             IF ( cumul_Cforcing ) THEN
+                CALL ipslerr (1,'stomate', &
+                     &          'Internal parameter cumul_Cforcing is TRUE in stomate.f90', &
+                     &          'Parameter FORCESOIL_NB_YEAR is forced to 1.', &
+                     &          'Then variable nbyear is forced to 1.')
+                nbyear=1
+             ENDIF
+
+             dt_forcesoil = zero
+             nparan = nparan+1
+             DO WHILE (dt_forcesoil < dt_slow/one_day)
+                nparan = nparan-1
+                IF (nparan < 1) THEN
+                   STOP 'Problem 1 with number of soil forcing time steps.'
+                ENDIF
+                dt_forcesoil = one_year/REAL(nparan,r_std)
+             ENDDO
+
+             IF ( nparan > nparanmax ) THEN
+                STOP 'Problem 2 with number of soil forcing time steps.'
+             ENDIF
+
+             WRITE(numout,*) 'time step of soil forcing (d): ',dt_forcesoil
+
+             ALLOCATE( nforce(nparan*nbyear))
+             nforce(:) = 0
+
+             ALLOCATE(control_moist(kjpindex,nlevs,nparan*nbyear))
+             ALLOCATE(npp_equil(kjpindex,nparan*nbyear))
+             ALLOCATE(npp_tot(kjpindex))
+             ALLOCATE(control_temp(kjpindex,nlevs,nparan*nbyear))
+             ALLOCATE(soilcarbon_input(kjpindex,ncarb,nvm,nparan*nbyear)) 
+
+             npp_equil(:,:) = zero
+             npp_tot(:) = zero
+             control_moist(:,:,:) = zero
+             control_temp(:,:,:) = zero
+             soilcarbon_input(:,:,:,:) = zero
+          ENDIF
+       ENDIF
+       !
+       ! 1.8 calculate STOMATE's vegetation fractions
+       !     from veget, veget_max
+       !
+       DO j=1,nvm
+          WHERE ((1.-totfrac_nobio(:)) > min_sechiba)
+             veget_cov(:,j)=veget(:,j)/( 1.-totfrac_nobio(:) )
+             veget_cov_max(:,j)=veget_max(:,j)/( 1.-totfrac_nobio(:) )
+          ELSEWHERE
+             veget_cov(:,j) = zero
+             veget_cov_max(:,j) = zero
+          ENDWHERE
+       ENDDO
+       IF ( EndOfYear ) THEN
+          DO j=1,nvm
+             WHERE ((1.-totfrac_nobio_new(:)) > min_sechiba)
+                veget_cov_max_new(:,j)=veget_max_new(:,j)/( 1.-totfrac_nobio_new(:) )
+             ELSEWHERE
+                veget_cov_max_new(:,j) = zero
+             ENDWHERE
+          ENDDO
+       ENDIF
+       !
+       ! 1.9 initialize some variables
+       !     STOMATE diagnoses some variables for SECHIBA :
+       !       assim_param, deadleaf_cover, etc.
+       !     These variables can be recalculated easily
+       !     from STOMATE's prognostic variables.
+       !     height is saved in Sechiba.
+       !
+       IF (control%ok_stomate) THEN
+          CALL stomate_var_init &
+               &         (kjpindex, veget_cov, veget_cov_max, leaf_age, leaf_frac, &
+               &          tlong_ref, t2m_month, dead_leaves, &
+               &          veget, lai, qsintmax, deadleaf_cover, assim_param)
+          harvest_above = zero
+       ENDIF
+       !
+       ! 1.10 reset flag
+       !
+       l_first_stomate = .FALSE.
+       !
+       ! 1.11 return
+       !
+       RETURN
+    ENDIF  ! first call
+    IF (bavard >= 4) THEN
+       WRITE(numout,*) 'DATE ',date,' ymds', year, month, day, sec, '-- stp --', itime, do_slow
+    ENDIF
+    !-
+    ! 2 prepares restart file for the next simulation
+    !-
+    IF (ldrestart_write) THEN
+       IF (long_print) THEN
+          WRITE (numout,*) &
+               &      ' we have to complete restart file with STOMATE variables'
+       ENDIF
+       CALL writerestart &
+            &         (kjpindex, index, &
+            &          day_counter, dt_days, date, &
+            &          ind, adapted, regenerate, &
+            &          humrel_daily, litterhum_daily, &
+            &          t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
+            &          soilhum_daily, precip_daily, &
+            &          gpp_daily, npp_daily, turnover_daily, &
+            &          humrel_month, humrel_week, &
+            &          t2m_longterm, tlong_ref, t2m_month, t2m_week, &
+            &          tsoil_month, soilhum_month, fireindex, firelitter, &
+            &          maxhumrel_lastyear, maxhumrel_thisyear, &
+            &          minhumrel_lastyear, minhumrel_thisyear, &
+            &          maxgppweek_lastyear, maxgppweek_thisyear, &
+            &          gdd0_lastyear, gdd0_thisyear, &
+            &          precip_lastyear, precip_thisyear, &
+            &          gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+            &          PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
+            &          maxfpc_lastyear, maxfpc_thisyear, &
+            &          turnover_longterm, gpp_week, biomass, resp_maint_part, &
+            &          leaf_age, leaf_frac, &
+            &          senescence, when_growthinit, age, &
+            &          resp_hetero_d, resp_maint_d, resp_growth_d, co2_fire, co2_to_bm_dgvm, &
+            &          veget_lastlight, everywhere, need_adjacent, &
+            &          RIP_time, time_lowgpp, &
+            &          time_hum_min, hum_min_dormance, &
+            &          litterpart, litter, dead_leaves, &
+            &          carbon, black_carbon, lignin_struc,turnover_time,&
+            &          prod10,prod100,flux10, flux100, &
+            &          convflux, cflux_prod10, cflux_prod100, bm_to_litter)
+
+       IF (ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN  
+          CALL forcing_write(forcing_id,1,iisf)
+          !
+          IF (is_root_prc) ier = NF90_CLOSE (forcing_id)
+          forcing_id=-1
+       ENDIF
+
+       IF (ldcarbon_write .AND. TRIM(Cforcing_name) /= 'NONE' ) THEN  
+          WRITE(numout,*) &
+               &      'stomate: writing the forcing file for carbon spinup'
+          !
+          DO iatt = 1, nparan*nbyear
+             IF ( nforce(iatt) > 0 ) THEN
+                soilcarbon_input(:,:,:,iatt) = &
+                     &          soilcarbon_input(:,:,:,iatt)/REAL(nforce(iatt),r_std)
+                control_moist(:,:,iatt) = &
+                     &          control_moist(:,:,iatt)/REAL(nforce(iatt),r_std)
+                control_temp(:,:,iatt) = &
+                     &          control_temp(:,:,iatt)/REAL(nforce(iatt),r_std)
+                npp_equil(:,iatt) = &
+                     &          npp_equil(:,iatt)/REAL(nforce(iatt),r_std)
+             ELSE
+                WRITE(numout,*) &
+                     &         'We have no soil carbon forcing data for this time step:', &
+                     &         iatt
+                WRITE(numout,*) ' -> we set them to zero'
+                soilcarbon_input(:,:,:,iatt) = zero
+                control_moist(:,:,iatt) = zero
+                control_temp(:,:,iatt) = zero
+                npp_equil(:,iatt) = zero
+             ENDIF
+          ENDDO
+
+          IF (is_root_prc) THEN
+             ALLOCATE(soilcarbon_input_g(nbp_glo,ncarb,nvm,nparan*nbyear))
+             ALLOCATE(control_moist_g(nbp_glo,nlevs,nparan*nbyear))
+             ALLOCATE(control_temp_g(nbp_glo,nlevs,nparan*nbyear))
+             ALLOCATE(npp_equil_g(nbp_glo,nparan*nbyear))
+          ENDIF
+
+          CALL gather(clay,clay_g)
+          CALL gather(soilcarbon_input,soilcarbon_input_g)
+          CALL gather(control_moist,control_moist_g)
+          CALL gather(control_temp,control_temp_g)
+          CALL gather(npp_equil,npp_equil_g)
+
+          !-
+          IF (is_root_prc) THEN
+             ier = NF90_CREATE (TRIM(Cforcing_name),NF90_WRITE,Cforcing_id)
+             ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
+                  &                        'kjpindex',REAL(nbp_glo,r_std))
+             ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
+                  &                        'nparan',REAL(nparan,r_std))
+             ier = NF90_PUT_ATT (Cforcing_id,NF90_GLOBAL, &
+                  &                        'nbyear',REAL(nbyear,r_std))
+             ier = NF90_DEF_DIM (Cforcing_id,'points',nbp_glo,d_id(1))
+             ier = NF90_DEF_DIM (Cforcing_id,'carbtype',ncarb,d_id(2))
+             ier = NF90_DEF_DIM (Cforcing_id,'vegtype',nvm,d_id(3))
+             ier = NF90_DEF_DIM (Cforcing_id,'level',nlevs,d_id(4))
+             ier = NF90_DEF_DIM (Cforcing_id,'time_step',nparan*nbyear,d_id(5))
+             !-
+             ier = NF90_DEF_VAR (Cforcing_id,'points',    r_typ,d_id(1),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'carbtype',  r_typ,d_id(2),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'vegtype',   r_typ,d_id(3),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'level',     r_typ,d_id(4),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'time_step', r_typ,d_id(5),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'index',     r_typ,d_id(1),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'clay',      r_typ,d_id(1),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'soilcarbon_input',r_typ, &
+                  &                        (/ d_id(1),d_id(2),d_id(3),d_id(5) /),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'control_moist',r_typ, &
+                  &                        (/ d_id(1),d_id(4),d_id(5) /),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'control_temp',r_typ, &
+                  &                        (/ d_id(1),d_id(4),d_id(5) /),vid)
+             ier = NF90_DEF_VAR (Cforcing_id,'npp_equil',r_typ, &
+                  &                        (/ d_id(1),d_id(5) /),vid)
+             ier = NF90_ENDDEF (Cforcing_id)
+             !-
+             ier = NF90_INQ_VARID (Cforcing_id,'points',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, &
+                  &                          (/(REAL(i,r_std),i=1,nbp_glo)/))
+             ier = NF90_INQ_VARID (Cforcing_id,'carbtype',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, &
+                  &                        (/(REAL(i,r_std),i=1,ncarb)/))
+             ier = NF90_INQ_VARID (Cforcing_id,'vegtype',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, &
+                  &                            (/(REAL(i,r_std),i=1,nvm)/))
+             ier = NF90_INQ_VARID (Cforcing_id,'level',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, &
+                  &                          (/(REAL(i,r_std),i=1,nlevs)/))
+             ier = NF90_INQ_VARID (Cforcing_id,'time_step',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, &
+                  &                          (/(REAL(i,r_std),i=1,nparan*nbyear)/))
+             ier = NF90_INQ_VARID (Cforcing_id,'index',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, REAL(index_g,r_std) )
+             ier = NF90_INQ_VARID (Cforcing_id,'clay',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, clay_g )
+             ier = NF90_INQ_VARID (Cforcing_id,'soilcarbon_input',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, soilcarbon_input_g )
+             ier = NF90_INQ_VARID (Cforcing_id,'control_moist',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, control_moist_g )
+             ier = NF90_INQ_VARID (Cforcing_id,'control_temp',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, control_temp_g )
+             ier = NF90_INQ_VARID (Cforcing_id,'npp_equil',vid)
+             ier = NF90_PUT_VAR (Cforcing_id,vid, npp_equil_g )
+             !-
+             ier = NF90_CLOSE (Cforcing_id)
+             Cforcing_id = -1
+          ENDIF
+
+          IF (is_root_prc) THEN
+             DEALLOCATE(soilcarbon_input_g)
+             DEALLOCATE(control_moist_g)
+             DEALLOCATE(control_temp_g)
+             DEALLOCATE(npp_equil_g)
+          ENDIF
+       ENDIF
+       RETURN
+    ENDIF  ! write restart-files
+    !
+    ! 4 Special treatment for some input arrays.
+    !
+    !
+    ! 4.1 Sum of liquid and solid precipitation
+    !
+    precip = ( precip_rain+precip_snow )*one_day/dtradia
+    !
+    ! 4.2 Copy.
+    !
+    ! 4.2.1 calculate STOMATE's vegetation fractions
+    !       from veget and  veget_max
+    !
+    DO j=1,nvm 
+       WHERE ((1.-totfrac_nobio(:)) > min_sechiba)
+          veget_cov(:,j)=veget(:,j)/( 1.-totfrac_nobio(:) )
+          veget_cov_max(:,j)=veget_max(:,j)/( 1.-totfrac_nobio(:) )
+       ELSEWHERE
+          veget_cov(:,j) = zero
+          veget_cov_max(:,j) = zero
+       ENDWHERE
+    ENDDO
+    IF ( EndOfYear ) THEN
+       DO j=1,nvm
+          WHERE ((1.-totfrac_nobio(:)) > min_sechiba)
+             veget_cov_max_new(:,j)=veget_max_new(:,j)/( 1.-totfrac_nobio(:) )
+          ELSEWHERE
+             veget_cov_max_new(:,j) = zero
+          ENDWHERE
+       ENDDO
+    ENDIF
+    gpp_d(:,1) = zero
+    DO j = 2,nvm   
+       ! 4.2.2 GPP
+       ! gpp in gC/m**2 of total ground/day
+       WHERE (veget_cov_max(:,j) > min_stomate)
+          gpp_d(:,j) =  gpp(:,j)/ veget_cov_max(:,j)* one_day/dtradia  
+       ELSEWHERE
+          gpp_d(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    IF ( day == 1 .AND. sec .LT. dtradia ) THEN
+       EndOfMonth=.TRUE.
+    ELSE
+       EndOfMonth=.FALSE.
+    ENDIF
+    !
+    ! 5 "daily" variables
+    !   Note: If dt_days /= 1, then xx_daily are not daily variables,
+    !         but that is not really a problem.
+    !
+    !
+    ! 5.1 accumulate instantaneous variables
+    !     and eventually calculate daily mean value
+    !
+
+    CALL stomate_accu (kjpindex, nvm, dt_slow, dtradia, &
+         &                   do_slow, humrel, humrel_daily)
+    CALL stomate_accu (kjpindex,    1, dt_slow, dtradia, &
+         &                   do_slow, litterhumdiag, litterhum_daily)
+    CALL stomate_accu (kjpindex,    1, dt_slow, dtradia, &
+         &                   do_slow, t2m, t2m_daily)
+    CALL stomate_accu (kjpindex,    1, dt_slow, dtradia, &
+         &                   do_slow, temp_sol, tsurf_daily)
+    CALL stomate_accu (kjpindex, nbdl, dt_slow, dtradia, &
+         &                   do_slow, stempdiag, tsoil_daily)
+    CALL stomate_accu (kjpindex, nbdl, dt_slow, dtradia, &
+         &                   do_slow, shumdiag, soilhum_daily)
+    CALL stomate_accu (kjpindex,    1, dt_slow, dtradia, &
+         &                   do_slow, precip, precip_daily)
+    CALL stomate_accu (kjpindex, nvm, dt_slow, dtradia, &
+         &                     do_slow, gpp_d, gpp_daily)
+
+    !
+    ! 5.2 daily minimum temperature
+    !
+    t2m_min_daily(:) = MIN( t2m_min(:), t2m_min_daily(:) )
+    !
+    ! 5.3 calculate respiration (NV 14/5/2002)
+    !
+    ! 5.3.1 calculate maintenance respiration
+    !
+    !NV maintenant lai est passé comme argument car on n'a plus les problemes de nat/agri!
+    !donc plus à etre calculé ici.... 
+    CALL maint_respiration &
+         &  (kjpindex,dtradia,lai,t2m,tlong_ref,stempdiag,height,veget_cov_max, &
+         &   rprof,biomass,resp_maint_part_radia)
+
+    resp_maint_radia(:,:) = zero
+    DO j=2,nvm
+       DO k= 1, nparts
+          resp_maint_radia(:,j) = resp_maint_radia(:,j) &
+               &                           +resp_maint_part_radia(:,j,k)
+       ENDDO
+    ENDDO
+    resp_maint_part(:,:,:)= resp_maint_part(:,:,:) &
+         &                       +resp_maint_part_radia(:,:,:)
+    !
+    ! 5.3.2 the whole litter stuff:
+    !       litter update, lignin content, PFT parts, litter decay,
+    !       litter heterotrophic respiration, dead leaf soil cover.
+    !        No vertical discretisation in the soil for litter decay.
+    !
+    turnover_littercalc = turnover_daily * dtradia/one_day
+    bm_to_littercalc    = bm_to_litter*dtradia/one_day
+
+    CALL littercalc (kjpindex, dtradia/one_day, &
+         turnover_littercalc, bm_to_littercalc, &
+         veget_cov_max, temp_sol, stempdiag, shumdiag, litterhumdiag, &
+         litterpart, litter, dead_leaves, lignin_struc, &
+         deadleaf_cover, resp_hetero_litter, &
+         soilcarbon_input_inst, control_temp_inst, control_moist_inst)
+    resp_hetero_litter=resp_hetero_litter*dtradia/one_day
+    !
+    ! 5.3.3 soil carbon dynamics: heterotrophic respiration from the soil.
+    !       For the moment, no vertical discretisation.
+    !       We might later introduce a vertical discretisation.
+    !       However, in that case, we would have to treat the vertical
+    !       exchanges of carbon between the different levels.
+    !
+    CALL soilcarbon (kjpindex, dtradia/one_day, clay, &
+         soilcarbon_input_inst, control_temp_inst, control_moist_inst, &
+         carbon, resp_hetero_soil)
+    resp_hetero_soil=resp_hetero_soil*dtradia/one_day
+    resp_hetero_radia = resp_hetero_litter+resp_hetero_soil
+    resp_hetero_d = resp_hetero_d + resp_hetero_radia
+    CALL stomate_accu (kjpindex, nlevs, dt_slow, dtradia, &
+ &                     do_slow, control_moist_inst, control_moist_daily)
+    CALL stomate_accu (kjpindex, nlevs, dt_slow, dtradia, &
+ &                     do_slow, control_temp_inst, control_temp_daily)
+    DO i=1,ncarb
+       CALL stomate_accu (kjpindex, nvm, dt_slow, dtradia, &
+            &                     do_slow, soilcarbon_input_inst(:,i,:), soilcarbon_input_daily(:,i,:))
+    ENDDO
+    !
+    ! 6 Daily processes
+    !
+    IF (do_slow) THEN
+
+       ! 6.0 update lai
+       IF (control%ok_pheno) THEN ! lai from stomate
+          lai(:,ibare_sechiba) = zero
+          DO j = 2, nvm
+             lai(:,j) = biomass(:,j,ileaf)*sla(j)
+          ENDDO
+       ELSE
+          CALL  setlai(kjpindex,lai) ! lai prescribed
+       ENDIF
+
+       !
+       ! 6.1 total natural space
+       !
+       !
+       ! 6.2 Calculate longer-term "meteorological" and biological parameters
+       !
+       CALL season &
+            &          (kjpindex, dt_days, EndOfYear, &
+            &           veget_cov, veget_cov_max, &
+            &           humrel_daily, t2m_daily, tsoil_daily, soilhum_daily, &
+            &           precip_daily, npp_daily, biomass, &
+            &           turnover_daily, gpp_daily, when_growthinit, &
+            &           maxhumrel_lastyear, maxhumrel_thisyear, &
+            &           minhumrel_lastyear, minhumrel_thisyear, &
+            &           maxgppweek_lastyear, maxgppweek_thisyear, &
+            &           gdd0_lastyear, gdd0_thisyear, &
+            &           precip_lastyear, precip_thisyear, &
+            &           lm_lastyearmax, lm_thisyearmax, &
+            &           maxfpc_lastyear, maxfpc_thisyear, &
+            &           humrel_month, humrel_week, t2m_longterm, &
+            &           tlong_ref, t2m_month, t2m_week, tsoil_month, soilhum_month, &
+            &           npp_longterm, turnover_longterm, gpp_week, &
+            &           gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+            &           time_lowgpp, time_hum_min, hum_min_dormance, herbivores)
+       !
+       ! 6.3 STOMATE: allocation, phenology, etc.
+       !
+       IF (control%ok_stomate) THEN
+
+          ! 6.3.1  call stomate
+
+          CALL StomateLpj &
+               &            (kjpindex, dt_days, EndOfYear, EndOfMonth, &
+               &             neighbours, resolution, &
+               &             clay, herbivores, &
+               &             tsurf_daily, tsoil_daily, t2m_daily, t2m_min_daily, &
+               &             litterhum_daily, soilhum_daily, &
+               &             maxhumrel_lastyear, minhumrel_lastyear, &
+               &             gdd0_lastyear, precip_lastyear, &
+               &             humrel_month, humrel_week, tlong_ref, t2m_month, t2m_week, &
+               &             tsoil_month, soilhum_month, &
+               &             gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+               &             turnover_longterm, gpp_daily, time_lowgpp, &
+               &             time_hum_min, maxfpc_lastyear, resp_maint_part,&
+               &             PFTpresent, age, fireindex, firelitter, &
+               &             leaf_age, leaf_frac, biomass, ind, adapted, regenerate, &
+               &             senescence, when_growthinit, litterpart, litter, &
+               &             dead_leaves, carbon, black_carbon, lignin_struc, &
+               &             veget_cov_max, veget_cov, npp_longterm, lm_lastyearmax, &
+               &             veget_lastlight, everywhere, need_adjacent, RIP_time, &
+               &             lai, rprof,npp_daily, turnover_daily, turnover_time,&
+               &             control_moist_inst, control_temp_inst, soilcarbon_input_inst, &
+               &             co2_to_bm_dgvm, co2_fire, &
+               &             resp_hetero_d, resp_maint_d, resp_growth_d, &
+               &             height, deadleaf_cover, vcmax, vjmax, &
+               &             t_photo_min, t_photo_opt, t_photo_max,bm_to_litter,&
+               &             prod10, prod100, flux10, flux100, veget_cov_max_new,&
+               &             convflux, cflux_prod10, cflux_prod100, harvest_above, lcchange)
+
+          !
+          ! 6.4 output: transform from dimension nvm to dimension nvm
+          !     Several Stomate-PFTs may correspond
+          !       to a single Sechiba-PFT (see 4.2).
+          !     We sum up the vegetation cover over these Stomate-PFTs.
+          !     Mean LAI, height, and Vmax is calculated
+          !       by ponderating with (maximum) vegetation cover.
+          !
+
+          ! 6.4.1 calculate veget, veget_max,
+          !         from veget_cov and veget_cov_max
+          veget(:,:) = zero 
+          veget_max(:,:) = zero 
+          !
+          DO j = 1, nvm
+             veget(:,j) = veget(:,j) + &
+                  &                        veget_cov(:,j) * ( 1.-totfrac_nobio(:) )
+             veget_max(:,j) = veget_max(:,j) + &
+                  &                            veget_cov_max(:,j) * ( 1.-totfrac_nobio(:) )
+          ENDDO
+          !
+          ! 6.4.2 photosynthesis parameters
+
+          assim_param(:,:,ivcmax) = zero
+          assim_param(:,:,ivjmax) = zero
+          assim_param(:,:,itmin) = zero
+          assim_param(:,:,itopt) = zero
+          assim_param(:,:,itmax) = zero
+
+          DO j = 2,nvm
+             assim_param(:,j,ivcmax)=vcmax(:,j)
+          ENDDO
+
+          DO j = 2, nvm
+             assim_param(:,j,ivjmax)=vjmax(:,j)
+          ENDDO
+
+          DO j = 2, nvm
+             assim_param(:,j,itmin)=t_photo_min(:,j)
+          ENDDO
+
+          DO j = 2, nvm
+             assim_param(:,j,itopt)=t_photo_opt(:,j)
+          ENDDO
+
+          DO j = 2, nvm
+             assim_param(:,j,itmax)=t_photo_max(:,j)
+          ENDDO
+
+          !
+          ! 6.5 update forcing variables for soil carbon
+          !
+          IF (ldcarbon_write  .AND. TRIM(Cforcing_name) /= 'NONE') THEN
+             npp_tot(:)=0
+
+             DO j=2,nvm
+                npp_tot(:)=npp_tot(:) + npp_daily(:,j)
+             ENDDO
+             sf_time = MODULO(REAL(date,r_std)-1,one_year*REAL(nbyear,r_std))
+             iatt=FLOOR(sf_time/dt_forcesoil)+1
+             IF ((iatt < 1) .OR. (iatt > nparan*nbyear)) THEN
+                WRITE(numout,*) 'Error with iatt=',iatt
+                CALL ipslerr (3,'stomate', &
+                     &          'Error with iatt.', '', &
+                     &          '(Problem with dt_forcesoil ?)')
+             ENDIF
+
+             IF ((iatt<iatt_old) .and. (.not. cumul_Cforcing)) THEN
+                nforce(:)=0
+                soilcarbon_input(:,:,:,:) = 0
+                control_moist(:,:,:) = 0
+                control_temp(:,:,:) = 0
+                npp_equil(:,:) = 0
+             ENDIF
+             iatt_old=iatt
+
+ 
+             nforce(iatt) = nforce(iatt)+1
+             soilcarbon_input(:,:,:,iatt) = soilcarbon_input(:,:,:,iatt)+ soilcarbon_input_daily(:,:,:)
+             control_moist(:,:,iatt) = control_moist(:,:,iatt)+ control_moist_daily(:,:)
+             control_temp(:,:,iatt) = control_temp(:,:,iatt)+ control_temp_daily(:,:)
+             npp_equil(:,iatt) = npp_equil(:,iatt)+npp_tot(:)
+          ENDIF
+          !
+          ! 6.6 updates qsintmax
+          !
+          DO j=2,nvm
+             qsintmax(:,j) = qsintcst * veget(:,j) * lai(:,j)
+          ENDDO
+       ENDIF
+       !
+       ! 6.7 write forcing file?
+       !     ldforcing_write should only be .TRUE.
+       !       if STOMATE is run in coupled mode.
+       !     In stand-alone mode, the forcing file is read!
+       !
+       IF ( ldforcing_write .AND. TRIM(forcing_name) /= 'NONE' ) THEN
+
+          gpp_daily_x(:,:) = zero
+          resp_maint_part_x(:,:,:) = zero
+          !gpp needs to be multiplied by coverage for forcing (see above)
+          DO j = 2, nvm             
+             gpp_daily_x(:,j) = gpp_daily_x(:,j) + &
+                  &                              gpp_daily(:,j) * dt_slow / one_day * veget_cov_max(:,j)
+             resp_maint_part_x(:,j,:) = resp_maint_part_x(:,j,:) + &
+                  &                              resp_maint_part(:,j,:) * dt_slow / one_day
+          ENDDO
+          !
+          ! bare soil moisture availability has not been treated
+          !   in STOMATE (doesn't matter)
+          !
+          humrel_daily(:,ibare_sechiba) = humrel(:,ibare_sechiba)   
+
+          ! next forcing step in memory
+          iisf = iisf+1
+
+          ! how many times have we treated this forcing state
+          xn = REAL(nf_cumul(isf(iisf)),r_std)
+
+          ! cumulate. be careful :
+          !   precipitation is multiplied by dt_slow/one_day
+          IF (cumul_forcing) THEN
+             clay_fm(:,iisf) = (xn*clay_fm(:,iisf)+clay(:))/(xn+1.)
+             humrel_daily_fm(:,:,iisf) = &
+                  &                (xn*humrel_daily_fm(:,:,iisf) + humrel_daily(:,:))/(xn+1.)
+             litterhum_daily_fm(:,iisf) = &
+                  &        (xn*litterhum_daily_fm(:,iisf)+litterhum_daily(:))/(xn+1.)
+             t2m_daily_fm(:,iisf) = &
+                  &        (xn*t2m_daily_fm(:,iisf)+t2m_daily(:))/(xn+1.)
+             t2m_min_daily_fm(:,iisf) = &
+                  &        (xn*t2m_min_daily_fm(:,iisf)+t2m_min_daily(:))/(xn+1.)
+             tsurf_daily_fm(:,iisf) = &
+                  &        (xn*tsurf_daily_fm(:,iisf)+tsurf_daily(:))/(xn+1.)
+             tsoil_daily_fm(:,:,iisf) = &
+                  &        (xn*tsoil_daily_fm(:,:,iisf)+tsoil_daily(:,:))/(xn+1.)
+             soilhum_daily_fm(:,:,iisf) = &
+                  &        (xn*soilhum_daily_fm(:,:,iisf)+soilhum_daily(:,:))/(xn+1.)
+             precip_fm(:,iisf) = &
+                  &        (xn*precip_fm(:,iisf)+precip_daily(:)*dt_slow/one_day)/(xn+1.)
+             gpp_daily_fm(:,:,iisf) = &
+                  &                (xn*gpp_daily_fm(:,:,iisf) + gpp_daily_x(:,:))/(xn+1.)
+             resp_maint_part_fm(:,:,:,iisf) = &
+                  &                ( xn*resp_maint_part_fm(:,:,:,iisf) &
+                  &         +resp_maint_part_x(:,:,:) )/(xn+1.)
+             veget_fm(:,:,iisf) = &
+                  &                (xn*veget_fm(:,:,iisf) + veget(:,:) )/(xn+1.)
+             veget_max_fm(:,:,iisf) = &
+                  &                (xn*veget_max_fm(:,:,iisf) + veget_max(:,:) )/(xn+1.)
+             lai_fm(:,:,iisf) = &
+                  &                (xn*lai_fm(:,:,iisf) + lai(:,:) )/(xn+1.)
+          ELSE
+             clay_fm(:,iisf) = clay(:)
+             humrel_daily_fm(:,:,iisf) = humrel_daily(:,:)
+             litterhum_daily_fm(:,iisf) = +litterhum_daily(:)
+             t2m_daily_fm(:,iisf) = t2m_daily(:)
+             t2m_min_daily_fm(:,iisf) =t2m_min_daily(:)
+             tsurf_daily_fm(:,iisf) = tsurf_daily(:)
+             tsoil_daily_fm(:,:,iisf) =tsoil_daily(:,:)
+             soilhum_daily_fm(:,:,iisf) =soilhum_daily(:,:)
+             precip_fm(:,iisf) = precip_daily(:)
+             gpp_daily_fm(:,:,iisf) =gpp_daily_x(:,:)
+             resp_maint_part_fm(:,:,:,iisf) = resp_maint_part_x(:,:,:)
+             veget_fm(:,:,iisf) = veget(:,:)
+             veget_max_fm(:,:,iisf) =veget_max(:,:)
+             lai_fm(:,:,iisf) =lai(:,:)
+          ENDIF
+          nf_cumul(isf(iisf)) = nf_cumul(isf(iisf))+1
+
+          ! do we have to write the forcing states?
+          IF (iisf == nsfm) THEN
+
+             ! write these forcing states
+             CALL forcing_write(forcing_id,1,nsfm)
+             ! determine which forcing states must be read
+             isf(1) = isf(nsfm)+1
+             IF ( isf(1) > nsft ) isf(1) = 1
+             DO iisf = 2, nsfm
+                isf(iisf) = isf(iisf-1)+1
+                IF (isf(iisf) > nsft)  isf(iisf) = 1
+             ENDDO
+
+             ! read them
+!for debug only!             CALL forcing_read(forcing_id,nsfm)
+
+             iisf = 0
+
+          ENDIF
+
+       ENDIF
+
+
+       ! 6.8 compute daily co2_flux
+
+       ! CO2 flux in gC/m**2/sec
+       !   (positive towards the atmosphere) is sum of:
+       ! 1/ heterotrophic respiration from ground
+       ! 2/ maintenance respiration from the plants
+       ! 3/ growth respiration from the plants
+       ! 4/ co2 created by fire
+       ! 5/ - co2 taken up in the DGVM to establish saplings.
+       ! 6/ - co2 taken up by photosyntyhesis
+
+       !NV co2_flux devient un champs dépendant du PFT
+       co2_flux_daily(:,:)=   &
+            & resp_maint_d(:,:) + resp_growth_d(:,:) + resp_hetero_d(:,:) + &
+            & co2_fire(:,:) - co2_to_bm_dgvm(:,:) - gpp_daily(:,:)
+
+       IF ( hist_id_stom_IPCC > 0 ) THEN
+          vartmp(:)=SUM(co2_flux_daily*veget_cov_max,dim=2)/1e3/one_day*contfrac
+          CALL histwrite (hist_id_stom_IPCC, "nep", itime, &
+               vartmp, kjpindex, hori_index)
+       ENDIF
+       !
+       co2_flux_monthly(:,:) = co2_flux_monthly(:,:) + co2_flux_daily(:,:)
+       IF ( EndOfMonth ) THEN
+          IF ( control%ok_stomate ) THEN
+             CALL histwrite (hist_id_stomate, 'CO2FLUX', itime, &
+                  co2_flux_monthly, kjpindex*nvm, horipft_index)
+          ENDIF
+!MM
+! Si on supprimer le cumul par mois, 
+! il ne faut pas oublier cette modif resolution(:,1)*resolution(:,2)*contfrac(:) 
+          DO j=2, nvm
+             co2_flux_monthly(:,j) = co2_flux_monthly(:,j)* &
+                  resolution(:,1)*resolution(:,2)*contfrac(:)
+          ENDDO
+          !NV modif calcul du net_co2_flux
+          net_co2_flux_monthly = zero
+          DO ji=1,kjpindex
+             DO j=2,nvm
+                net_co2_flux_monthly = net_co2_flux_monthly + &
+                     &  co2_flux_monthly(ji,j)*veget_max(ji,j)
+             ENDDO
+          ENDDO
+          net_co2_flux_monthly = net_co2_flux_monthly*1e-15
+          WRITE(numout,*) 'net_co2_flux_monthly (Peta gC/month)  = ',net_co2_flux_monthly
+
+          CALL reduce_sum(net_co2_flux_monthly,net_co2_flux_monthly_sum)
+          CALL bcast(net_co2_flux_monthly_sum)
+          WRITE(numout,*) 'GLOBAL net_co2_flux_monthly (Peta gC/month)  = ',net_co2_flux_monthly_sum
+
+!!$          IF ( control%ok_stomate ) THEN
+!!$             vartmp(:)=net_co2_flux_monthly_sum
+!!$             CALL histwrite (hist_id_stomate, 'CO2FLUX_MONTHLY_SUM', itime, &
+!!$                  vartmp, kjpindex, hori_index )
+!!$          ENDIF
+!!$          IF (is_root_prc) THEN
+!!$             OPEN( unit=39,              &
+!!$                  file="stomate_co2flux.data", &
+!!$                  action="write",              &
+!!$                  position="append",           &
+!!$                  iostat=ios  )
+!!$             IF ( ios /= 0 ) THEN
+!!$                STOP "Erreur lors de la lecture/ecriture du fichier stomate_co2flux.data"
+!!$             ELSE
+!!$                WRITE(numout,*)
+!!$                WRITE(numout,*) "Ecriture du fichier stomate_co2flux.data"
+!!$                WRITE(numout,*)
+!!$             END IF
+!!$             WRITE(39,*) net_co2_flux_monthly_sum
+!!$             CLOSE( unit=39 )
+!!$          ENDIF
+          co2_flux_monthly(:,:) = zero
+       ENDIF
+       !
+       ! 6.9 reset daily variables
+       !
+       humrel_daily(:,:) = zero
+       litterhum_daily(:) = zero
+       t2m_daily(:) = zero
+       t2m_min_daily(:) = large_value
+       tsurf_daily(:) = zero
+       tsoil_daily(:,:) = zero
+       soilhum_daily(:,:) = zero
+       precip_daily(:) = zero
+       gpp_daily(:,:) = zero
+       resp_maint_part(:,:,:)=zero
+       resp_hetero_d=zero
+       IF (bavard >= 3) THEN
+          WRITE(numout,*) 'stomate_main: daily processes done'
+       ENDIF
+
+    ENDIF  ! daily processes?
+    !
+    ! 7 Outputs from Stomate
+    !   co2_flux is assigned a value only if STOMATE is activated.
+    !   Otherwise, the calling hydrological module must do this itself.
+    !
+    IF ( control%ok_stomate ) THEN
+
+       resp_maint(:,:) = resp_maint_radia(:,:)*veget_cov_max(:,:)
+       resp_maint(:,ibare_sechiba) = zero
+       resp_growth(:,:)= resp_growth_d(:,:)*veget_cov_max(:,:)*dtradia/one_day
+       !
+       resp_hetero(:,:) = resp_hetero_radia(:,:)*veget_cov_max(:,:)
+
+       ! CO2 flux in gC/m**2/sec (positive towards the atmosphere) is sum of:
+       ! 1/ heterotrophic respiration from ground
+       ! 2/ maintenance respiration from the plants
+       ! 3/ growth respiration from the plants
+       ! 4/ co2 created by fire
+       ! 5/ - co2 taken up in the DGVM to establish saplings.
+       ! 6/ - co2 taken up by photosyntyhesis
+
+       co2_flux(:,:) = resp_hetero(:,:) + resp_maint(:,:) + resp_growth(:,:) &
+            & + (co2_fire(:,:)-co2_to_bm_dgvm(:,:))*veget_cov_max(:,:)/one_day &
+            & - gpp(:,:)
+
+    ENDIF
+    !
+    ! 8 message
+    !
+    IF ( (bavard >= 2).AND.EndOfYear.AND.do_slow) THEN
+       WRITE(numout,*) 'stomate: EndOfYear'
+    ENDIF
+    IF (bavard >= 4) WRITE(numout,*) 'Leaving stomate_main'
+    IF (long_print) WRITE (numout,*) ' stomate_main done '
+    !--------------------------
+  END SUBROUTINE stomate_main
+  !
+  !=
+  !
+  SUBROUTINE stomate_init &
+       &  (kjpij, kjpindex, index, ldforcing_write, lalo, &
+       &   rest_id_stom, hist_id_stom, hist_id_stom_IPCC)
+    !---------------------------------------------------------------------
+    ! interface description
+    ! input scalar
+    ! Total size of the un-compressed grid
+    INTEGER(i_std),INTENT(in)                   :: kjpij
+    ! Domain size
+    INTEGER(i_std),INTENT(in)                   :: kjpindex
+    ! Logical for _forcing_ file to write
+    LOGICAL,INTENT(in)                          :: ldforcing_write
+    ! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std),DIMENSION(kjpindex,2),INTENT(in) :: lalo
+    ! STOMATE's _Restart_ file file identifier
+    INTEGER(i_std),INTENT(in)                   :: rest_id_stom
+    ! STOMATE's _history_ file file identifier
+    INTEGER(i_std),INTENT(in)                   :: hist_id_stom
+    ! STOMATE's IPCC _history_ file file identifier
+    INTEGER(i_std),INTENT(in)                   :: hist_id_stom_IPCC
+    ! input fields
+    ! Indeces of the points on the map
+    INTEGER(i_std),DIMENSION(kjpindex),INTENT(in) :: index
+    ! local declaration
+    REAL(r_std)                                  :: tmp_day(1)
+    ! soil depth taken for canopy
+    REAL(r_std)                                  :: zcanop
+    ! soil depths at diagnostic levels
+    REAL(r_std),DIMENSION(nbdl)                  :: zsoil
+    ! Index
+    INTEGER(i_std)                              :: l
+    ! allocation error
+    LOGICAL                                     :: l_error
+    ! Global world fraction of vegetation type map
+    REAL(r_std),DIMENSION(360,180,nvm)           :: veget_ori_on_disk
+    INTEGER(i_std)                              :: ier
+    ! indices
+    INTEGER(i_std)                              :: ji,j,ipd
+    !---------------------------------------------------------------------
+    !
+    ! 1 online diagnostics
+    !   (by default, "bavard" is set to 1 in stomate_constants)
+    !
+    !Config  Key  = BAVARD
+    !Config  Desc = level of online diagnostics in STOMATE (0-4)
+    !Config  Def  = 1
+    !Config  Help = With this variable, you can determine
+    !Config         how much online information STOMATE
+    !Config         gives during the run. 0 means
+    !Config         virtually no info.
+    !
+    bavard = 1
+    CALL getin_p('BAVARD', bavard)
+
+    IF ( kjpindex > 0 ) THEN
+       !
+       !Config  Key  = STOMATE_DIAGPT
+       !Config  Desc = Index of grid point for online diagnostics
+       !Config  Def  = 1
+       !Config  Help = This is the index of the grid point which
+       !               will be used for online diagnostics.
+       ipd = 1
+       CALL getin_p('STOMATE_DIAGPT',ipd)
+       ipd = MIN( ipd, kjpindex )
+       WRITE(numout,*) 'Stomate: '
+       WRITE(numout,*) '  Index of grid point for online diagnostics: ',ipd
+       WRITE(numout,*) '  Lon, lat:',lalo(ipd,2),lalo(ipd,1)
+       WRITE(numout,*) '  Index of this point on GCM grid: ',index(ipd)
+       !
+    ENDIF
+    !
+    ! 2 check consistency of flags
+    !
+    IF ( ( .NOT. control%ok_stomate ) .AND. control%ok_dgvm ) THEN
+       WRITE(numout,*) 'Cannot do dynamical vegetation without STOMATE.'
+       WRITE(numout,*) 'We stop.'
+       STOP
+    ENDIF
+
+    IF ((.NOT.control%ok_co2).AND.control%ok_stomate) THEN
+       WRITE(numout,*) 'Cannot call STOMATE without GPP.'
+       WRITE(numout,*) 'We stop.'
+       STOP
+    ENDIF
+
+    IF ( ( .NOT. control%ok_co2 ) .AND. ldforcing_write ) THEN
+       WRITE(numout,*) &
+            &    'Cannot write forcing file if photosynthesis is not activated'
+       WRITE(numout,*) 'We stop.'
+       STOP
+    ENDIF
+    !
+    ! 3 messages
+    !
+    WRITE(numout,*) 'stomate: first call'
+    WRITE(numout,*) '  Photosynthesis: ', control%ok_co2
+    WRITE(numout,*) '  STOMATE: ', control%ok_stomate
+    WRITE(numout,*) '  LPJ: ', control%ok_dgvm
+    !
+    ! 4 allocation of STOMATE's variables
+    !
+    l_error = .FALSE.
+    ALLOCATE(veget_cov_max(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(veget_cov_max_new(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(ind(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(adapted(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(regenerate(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(humrel_daily(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(litterhum_daily(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_daily(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_min_daily(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(tsurf_daily(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(tsoil_daily(kjpindex,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(soilhum_daily(kjpindex,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(precip_daily(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(gpp_daily(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(npp_daily(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(turnover_daily(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(turnover_littercalc(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(humrel_month(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(humrel_week(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_longterm(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(tlong_ref(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_month(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_week(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(tsoil_month(kjpindex,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(soilhum_month(kjpindex,nbdl),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(fireindex(kjpindex,nvm),stat=ier) 
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(firelitter(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(maxhumrel_lastyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(maxhumrel_thisyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(minhumrel_lastyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(minhumrel_thisyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(maxgppweek_lastyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(maxgppweek_thisyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(gdd0_lastyear(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(gdd0_thisyear(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(precip_lastyear(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(precip_thisyear(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(gdd_m5_dormance(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(gdd_midwinter(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(ncd_dormance(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(ngd_minus5(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(PFTpresent(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(npp_longterm(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(lm_lastyearmax(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(lm_thisyearmax(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(maxfpc_lastyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(maxfpc_thisyear(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(turnover_longterm(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(gpp_week(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(biomass(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(senescence(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(when_growthinit(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(age(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_hetero_d(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_hetero_radia(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_maint_d(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_growth_d(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    !NV devient 2D
+    ALLOCATE(co2_fire(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    !NV devient 2D
+    ALLOCATE(co2_to_bm_dgvm(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(veget_lastlight(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(everywhere(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(need_adjacent(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(leaf_age(kjpindex,nvm,nleafages),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(leaf_frac(kjpindex,nvm,nleafages),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(RIP_time(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(time_lowgpp(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(time_hum_min(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(hum_min_dormance(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(litterpart(kjpindex,nvm,nlitt),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(litter(kjpindex,nlitt,nvm,nlevs),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(dead_leaves(kjpindex,nvm,nlitt),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(carbon(kjpindex,ncarb,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(black_carbon(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(lignin_struc(kjpindex,nvm,nlevs),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(turnover_time(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(co2_flux_daily(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(co2_flux_monthly(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(bm_to_litter(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(bm_to_littercalc(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(herbivores(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(hori_index(kjpindex),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(horipft_index(kjpindex*nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_maint_part_radia(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_maint_radia(kjpindex,nvm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_maint_part(kjpindex,nvm,nparts),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    resp_maint_part(:,:,:)=zero
+    ALLOCATE (horip10_index(kjpindex*10), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (horip100_index(kjpindex*100), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (horip11_index(kjpindex*11), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (horip101_index(kjpindex*101), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (prod10(kjpindex,0:10), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (prod100(kjpindex,0:100), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (flux10(kjpindex,10), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (flux100(kjpindex,100), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (convflux(kjpindex), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (cflux_prod10(kjpindex), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (cflux_prod100(kjpindex), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (harvest_above(kjpindex), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (soilcarbon_input_daily(kjpindex,ncarb,nvm), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (control_temp_daily(kjpindex,nlevs), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    ALLOCATE (control_moist_daily(kjpindex,nlevs), stat=ier)
+    l_error = l_error .OR. (ier.NE.0)
+    !
+    IF (l_error) THEN
+       STOP 'stomate_init: error in memory allocation'
+    ENDIF
+    !
+    ! 5 file definitions: stored in common variables
+    !
+    hist_id_stomate = hist_id_stom
+    hist_id_stomate_IPCC = hist_id_stom_IPCC
+    rest_id_stomate = rest_id_stom
+    hori_index(:) = index(:)
+
+    ! Get the indexing table for the vegetation fields.
+    ! In STOMATE we work on
+    ! reduced grids but to store in the full 3D filed vegetation variable
+    ! we need another index table : indexpft
+
+    DO j = 1, nvm
+       DO ji = 1, kjpindex
+          horipft_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
+       ENDDO
+    ENDDO
+
+    ! indexing tables added for land cover change fields
+    DO j = 1, 10
+       DO ji = 1, kjpindex
+          horip10_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
+       ENDDO
+    ENDDO
+
+    DO j = 1, 100
+       DO ji = 1, kjpindex
+          horip100_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
+       ENDDO
+    ENDDO
+
+    DO j = 1, 11
+       DO ji = 1, kjpindex
+          horip11_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
+       ENDDO
+    ENDDO
+
+    DO j = 1, 101
+       DO ji = 1, kjpindex
+          horip101_index((j-1)*kjpindex+ji) = index(ji)+(j-1)*kjpij
+       ENDDO
+    ENDDO
+    !
+    ! 6 some flags
+    !
+    !
+    !Config  Key  = HERBIVORES
+    !Config  Desc = herbivores allowed?
+    !Config  Def  = n
+    !Config  Help = With this variable, you can determine
+    !Config         if herbivores are activated
+    !
+    ok_herbivores = .FALSE.
+    CALL getin_p('HERBIVORES', ok_herbivores)
+    !
+    WRITE(numout,*) 'herbivores activated: ',ok_herbivores
+    !
+    !Config  Key  = TREAT_EXPANSION
+    !Config  Desc = treat expansion of PFTs across a grid cell?
+    !Config  Def  = n
+    !Config  Help = With this variable, you can determine
+    !Config         whether we treat expansion of PFTs across a
+    !Config         grid cell.
+    !
+    treat_expansion = .FALSE.
+    CALL getin_p('TREAT_EXPANSION', treat_expansion)
+    !
+    WRITE(numout,*) &
+         &  'expansion across a grid cell is treated: ',treat_expansion
+
+    !Config  Key  = HARVEST_AGRI
+    !Config  Desc = Harvert model for agricol PFTs.
+    !Config  Def  = y
+    !Config  Help = Compute harvest above ground biomass for agriculture.
+    !Config         Change daily turnover.
+    harvest_agri = .TRUE.
+    CALL getin_p('HARVEST_AGRI', harvest_agri)
+
+    !
+    ! 7 some global initializations
+    !
+    ! edit shilong
+    !   bm_to_litter(:,:,:) = zero
+    turnover_daily(:,:,:) = zero
+    resp_hetero_d(:,:) = zero
+    co2_flux_daily(:,:) = zero
+    co2_flux_monthly(:,:) = zero
+    control_moist_daily(:,:) = zero
+    control_temp_daily(:,:) = zero
+    soilcarbon_input_daily(:,:,:) = zero
+
+    ! initialisation of land cover change variables
+    prod10(:,:)  = zero
+    prod100(:,:) = zero
+    flux10(:,:)  = zero
+    flux100(:,:) = zero
+    convflux(:)  = zero
+    cflux_prod10(:) = zero
+    cflux_prod100(:)= zero
+    !--------------------------
+  END SUBROUTINE stomate_init
+  !
+  !=
+  !
+  SUBROUTINE stomate_clear
+    !---------------------------------------------------------------------
+    ! 1. Deallocate all dynamics variables
+    IF (ALLOCATED(veget_cov_max)) DEALLOCATE(veget_cov_max)
+    IF (ALLOCATED(veget_cov_max_new)) DEALLOCATE(veget_cov_max_new)
+    IF (ALLOCATED(ind)) DEALLOCATE(ind)
+    IF (ALLOCATED(adapted)) DEALLOCATE(adapted)
+    IF (ALLOCATED(regenerate)) DEALLOCATE(regenerate)
+    IF (ALLOCATED(humrel_daily)) DEALLOCATE(humrel_daily)
+    IF (ALLOCATED(litterhum_daily)) DEALLOCATE(litterhum_daily)
+    IF (ALLOCATED(t2m_daily))  DEALLOCATE(t2m_daily)
+    IF (ALLOCATED(t2m_min_daily))  DEALLOCATE(t2m_min_daily)
+    IF (ALLOCATED(tsurf_daily))  DEALLOCATE(tsurf_daily)
+    IF (ALLOCATED(tsoil_daily)) DEALLOCATE(tsoil_daily)
+    IF (ALLOCATED(soilhum_daily)) DEALLOCATE(soilhum_daily)
+    IF (ALLOCATED(precip_daily)) DEALLOCATE(precip_daily)
+    IF (ALLOCATED(gpp_daily)) DEALLOCATE(gpp_daily)
+    IF (ALLOCATED(npp_daily)) DEALLOCATE(npp_daily)
+    IF (ALLOCATED(turnover_daily)) DEALLOCATE(turnover_daily)
+    IF (ALLOCATED(turnover_littercalc)) DEALLOCATE(turnover_littercalc)
+    IF (ALLOCATED(humrel_month)) DEALLOCATE(humrel_month)
+    IF (ALLOCATED(humrel_week)) DEALLOCATE(humrel_week)
+    IF (ALLOCATED(t2m_longterm)) DEALLOCATE(t2m_longterm)
+    IF (ALLOCATED(tlong_ref)) DEALLOCATE(tlong_ref)
+    IF (ALLOCATED(t2m_month)) DEALLOCATE(t2m_month)
+    IF (ALLOCATED(t2m_week)) DEALLOCATE(t2m_week)
+    IF (ALLOCATED(tsoil_month)) DEALLOCATE(tsoil_month)
+    IF (ALLOCATED(soilhum_month)) DEALLOCATE(soilhum_month)
+    IF (ALLOCATED(fireindex)) DEALLOCATE(fireindex)
+    IF (ALLOCATED(firelitter)) DEALLOCATE(firelitter)
+    IF (ALLOCATED(maxhumrel_lastyear)) DEALLOCATE(maxhumrel_lastyear)
+    IF (ALLOCATED(maxhumrel_thisyear)) DEALLOCATE(maxhumrel_thisyear)
+    IF (ALLOCATED(minhumrel_lastyear)) DEALLOCATE(minhumrel_lastyear)
+    IF (ALLOCATED(minhumrel_thisyear)) DEALLOCATE(minhumrel_thisyear)
+    IF (ALLOCATED(maxgppweek_lastyear)) DEALLOCATE(maxgppweek_lastyear)
+    IF (ALLOCATED(maxgppweek_thisyear)) DEALLOCATE(maxgppweek_thisyear)
+    IF (ALLOCATED(gdd0_lastyear)) DEALLOCATE(gdd0_lastyear)
+    IF (ALLOCATED(gdd0_thisyear)) DEALLOCATE(gdd0_thisyear)
+    IF (ALLOCATED(precip_lastyear)) DEALLOCATE(precip_lastyear)
+    IF (ALLOCATED(precip_thisyear)) DEALLOCATE(precip_thisyear)
+    IF (ALLOCATED(gdd_m5_dormance)) DEALLOCATE(gdd_m5_dormance)
+    IF (ALLOCATED(gdd_midwinter)) DEALLOCATE(gdd_midwinter)
+    IF (ALLOCATED(ncd_dormance)) DEALLOCATE(ncd_dormance)
+    IF (ALLOCATED(ngd_minus5))  DEALLOCATE(ngd_minus5)
+    IF (ALLOCATED(PFTpresent)) DEALLOCATE(PFTpresent)
+    IF (ALLOCATED(npp_longterm)) DEALLOCATE(npp_longterm)
+    IF (ALLOCATED(lm_lastyearmax)) DEALLOCATE(lm_lastyearmax)
+    IF (ALLOCATED(lm_thisyearmax)) DEALLOCATE(lm_thisyearmax)
+    IF (ALLOCATED(maxfpc_lastyear)) DEALLOCATE(maxfpc_lastyear)
+    IF (ALLOCATED(maxfpc_thisyear)) DEALLOCATE(maxfpc_thisyear)
+    IF (ALLOCATED(turnover_longterm)) DEALLOCATE(turnover_longterm)
+    IF (ALLOCATED(gpp_week)) DEALLOCATE(gpp_week)
+    IF (ALLOCATED(biomass)) DEALLOCATE(biomass)
+    IF (ALLOCATED(senescence)) DEALLOCATE(senescence)
+    IF (ALLOCATED(when_growthinit)) DEALLOCATE(when_growthinit)
+    IF (ALLOCATED(age))  DEALLOCATE(age)
+    IF (ALLOCATED(resp_hetero_d)) DEALLOCATE(resp_hetero_d)
+    IF (ALLOCATED(resp_hetero_radia)) DEALLOCATE(resp_hetero_radia)
+    IF (ALLOCATED(resp_maint_d)) DEALLOCATE(resp_maint_d)
+    IF (ALLOCATED(resp_growth_d)) DEALLOCATE(resp_growth_d)
+    IF (ALLOCATED(co2_fire)) DEALLOCATE(co2_fire)
+    IF (ALLOCATED(co2_to_bm_dgvm)) DEALLOCATE(co2_to_bm_dgvm)
+    IF (ALLOCATED(veget_lastlight)) DEALLOCATE(veget_lastlight)
+    IF (ALLOCATED(everywhere)) DEALLOCATE(everywhere)
+    IF (ALLOCATED(need_adjacent)) DEALLOCATE(need_adjacent)
+    IF (ALLOCATED(leaf_age)) DEALLOCATE(leaf_age)
+    IF (ALLOCATED(leaf_frac)) DEALLOCATE(leaf_frac)
+    IF (ALLOCATED(RIP_time)) DEALLOCATE(RIP_time)
+    IF (ALLOCATED(time_lowgpp)) DEALLOCATE(time_lowgpp)
+    IF (ALLOCATED(time_hum_min)) DEALLOCATE(time_hum_min)
+    IF (ALLOCATED(hum_min_dormance)) DEALLOCATE(hum_min_dormance)
+    IF (ALLOCATED(litterpart)) DEALLOCATE(litterpart)
+    IF (ALLOCATED(litter)) DEALLOCATE(litter)
+    IF (ALLOCATED(dead_leaves)) DEALLOCATE(dead_leaves)
+    IF (ALLOCATED(carbon)) DEALLOCATE(carbon)
+    IF (ALLOCATED(black_carbon)) DEALLOCATE(black_carbon)
+    IF (ALLOCATED(lignin_struc)) DEALLOCATE(lignin_struc)
+    IF (ALLOCATED(turnover_time)) DEALLOCATE(turnover_time)
+    IF (ALLOCATED(co2_flux_daily)) DEALLOCATE(co2_flux_daily)
+    IF (ALLOCATED(co2_flux_monthly)) DEALLOCATE(co2_flux_monthly)
+    IF (ALLOCATED(bm_to_litter)) DEALLOCATE(bm_to_litter)
+    IF (ALLOCATED(bm_to_littercalc)) DEALLOCATE(bm_to_littercalc)
+    IF (ALLOCATED(herbivores)) DEALLOCATE(herbivores)
+    IF (ALLOCATED(resp_maint_part_radia)) DEALLOCATE(resp_maint_part_radia)
+    IF (ALLOCATED(resp_maint_radia)) DEALLOCATE(resp_maint_radia)
+    IF (ALLOCATED(resp_maint_part)) DEALLOCATE(resp_maint_part)
+    IF (ALLOCATED(hori_index)) DEALLOCATE(hori_index)
+    IF (ALLOCATED(horipft_index)) DEALLOCATE(horipft_index)
+    IF (ALLOCATED(clay_fm)) DEALLOCATE(clay_fm)
+    IF (ALLOCATED(humrel_daily_fm)) DEALLOCATE(humrel_daily_fm)
+    IF (ALLOCATED(litterhum_daily_fm))  DEALLOCATE(litterhum_daily_fm)
+    IF (ALLOCATED(t2m_daily_fm))  DEALLOCATE(t2m_daily_fm)
+    IF (ALLOCATED(t2m_min_daily_fm))  DEALLOCATE(t2m_min_daily_fm)
+    IF (ALLOCATED(tsurf_daily_fm)) DEALLOCATE(tsurf_daily_fm)
+    IF (ALLOCATED(tsoil_daily_fm)) DEALLOCATE(tsoil_daily_fm)
+    IF (ALLOCATED(soilhum_daily_fm))  DEALLOCATE(soilhum_daily_fm)
+    IF (ALLOCATED(precip_fm)) DEALLOCATE(precip_fm)
+    IF (ALLOCATED(gpp_daily_fm))  DEALLOCATE(gpp_daily_fm)
+    IF (ALLOCATED(resp_maint_part_fm))  DEALLOCATE(resp_maint_part_fm)
+    IF (ALLOCATED(veget_fm)) DEALLOCATE(veget_fm)
+    IF (ALLOCATED(veget_max_fm)) DEALLOCATE(veget_max_fm)
+    IF (ALLOCATED(lai_fm))  DEALLOCATE(lai_fm)
+
+    IF (is_root_prc) THEN
+       IF (ALLOCATED(clay_fm_g)) DEALLOCATE(clay_fm_g)
+       IF (ALLOCATED(humrel_daily_fm_g)) DEALLOCATE(humrel_daily_fm_g)
+       IF (ALLOCATED(litterhum_daily_fm_g))  DEALLOCATE(litterhum_daily_fm_g)
+       IF (ALLOCATED(t2m_daily_fm_g))  DEALLOCATE(t2m_daily_fm_g)
+       IF (ALLOCATED(t2m_min_daily_fm_g))  DEALLOCATE(t2m_min_daily_fm_g)
+       IF (ALLOCATED(tsurf_daily_fm_g)) DEALLOCATE(tsurf_daily_fm_g)
+       IF (ALLOCATED(tsoil_daily_fm_g)) DEALLOCATE(tsoil_daily_fm_g)
+       IF (ALLOCATED(soilhum_daily_fm_g))  DEALLOCATE(soilhum_daily_fm_g)
+       IF (ALLOCATED(precip_fm_g)) DEALLOCATE(precip_fm_g)
+       IF (ALLOCATED(gpp_daily_fm_g))  DEALLOCATE(gpp_daily_fm_g)
+       IF (ALLOCATED(resp_maint_part_fm_g))  DEALLOCATE(resp_maint_part_fm_g)
+       IF (ALLOCATED(veget_fm_g)) DEALLOCATE(veget_fm_g)
+       IF (ALLOCATED(veget_max_fm_g)) DEALLOCATE(veget_max_fm_g)
+       IF (ALLOCATED(lai_fm_g))  DEALLOCATE(lai_fm_g)
+    ENDIF
+
+    IF (ALLOCATED(isf)) DEALLOCATE(isf)
+    IF (ALLOCATED(nf_written)) DEALLOCATE(nf_written)
+    IF (ALLOCATED(nf_cumul)) DEALLOCATE(nf_cumul)
+    IF (ALLOCATED(nforce)) DEALLOCATE(nforce)
+    IF (ALLOCATED(control_moist)) DEALLOCATE(control_moist)
+    IF (ALLOCATED(control_temp)) DEALLOCATE(control_temp)
+    IF (ALLOCATED(soilcarbon_input)) DEALLOCATE(soilcarbon_input)
+    IF ( ALLOCATED (horip10_index)) DEALLOCATE (horip10_index)
+    IF ( ALLOCATED (horip100_index)) DEALLOCATE (horip100_index)
+    IF ( ALLOCATED (horip11_index)) DEALLOCATE (horip11_index)
+    IF ( ALLOCATED (horip101_index)) DEALLOCATE (horip101_index)
+    IF ( ALLOCATED (prod10)) DEALLOCATE (prod10)
+    IF ( ALLOCATED (prod100)) DEALLOCATE (prod100)
+    IF ( ALLOCATED (flux10)) DEALLOCATE (flux10)
+    IF ( ALLOCATED (flux100)) DEALLOCATE (flux100)
+    IF ( ALLOCATED (convflux)) DEALLOCATE (convflux)
+    IF ( ALLOCATED (cflux_prod10)) DEALLOCATE (cflux_prod10)
+    IF ( ALLOCATED (cflux_prod100)) DEALLOCATE (cflux_prod100)
+    IF ( ALLOCATED (harvest_above)) DEALLOCATE (harvest_above)
+    IF ( ALLOCATED (soilcarbon_input_daily)) DEALLOCATE (soilcarbon_input_daily)
+    IF ( ALLOCATED (control_temp_daily)) DEALLOCATE (control_temp_daily)
+    IF ( ALLOCATED (control_moist_daily)) DEALLOCATE (control_moist_daily)
+
+    ! 2. reset l_first
+    l_first_stomate=.TRUE.
+    ! 3. call to clear functions
+    CALL get_reftemp_clear
+    CALL season_clear
+    CALL stomatelpj_clear
+    CALL littercalc_clear
+    CALL vmax_clear
+    !---------------------------
+  END SUBROUTINE stomate_clear
+  !
+  !=
+  !
+  SUBROUTINE stomate_var_init &
+       &  (kjpindex, veget_cov, veget_cov_max, leaf_age, leaf_frac, &
+       &   tlong_ref, t2m_month, dead_leaves, &
+       &   veget, lai, qsintmax, deadleaf_cover, assim_param)
+
+    !---------------------------------------------------------------------
+    ! this subroutine outputs values of assim_param etc.
+    ! only if ok_stomate = .TRUE.
+    ! otherwise,the calling procedure must do it itself.
+    !
+    ! interface description
+    ! input scalar
+    ! Domain size
+    INTEGER(i_std),INTENT(in)                            :: kjpindex
+    ! input fields
+    ! fractional coverage: actually covered space
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in)       :: veget_cov
+    ! fractional coverage: maximum covered space
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in)       :: veget_cov_max
+    ! "long term" 2 meter reference temperatures (K)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)            :: tlong_ref
+    ! "monthly" 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(kjpindex),INTENT(in)            :: t2m_month
+    ! dead leaves on ground, per PFT, metabolic and structural,
+    !  in gC/(m**2 of ground)
+    REAL(r_std),DIMENSION(kjpindex,nvm,nlitt),INTENT(in) :: dead_leaves
+    ! Fraction of vegetation type
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in)        :: veget
+    ! Surface foliere
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(in)        :: lai
+    ! modified fields (actually NOT modified)
+    ! leaf age (d)
+    REAL(r_std),DIMENSION(kjpindex,nvm,nleafages),INTENT(inout) :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std),DIMENSION(kjpindex,nvm,nleafages),INTENT(inout) :: leaf_frac
+    ! output scalar
+    ! output fields
+    ! Maximum water on vegetation for interception
+    REAL(r_std),DIMENSION(kjpindex,nvm),INTENT(out)       :: qsintmax
+    ! fraction of soil covered by dead leaves
+    REAL(r_std),DIMENSION(kjpindex), INTENT (out)         :: deadleaf_cover
+    ! min+max+opt temps & vmax for photosynthesis
+    REAL(r_std),DIMENSION(kjpindex,nvm,npco2),INTENT(out) :: assim_param
+
+    !-
+    ! local declaration
+    !-
+    ! dummy time step, must be zero
+    REAL(r_std),PARAMETER                        :: dt_0 = zero
+    REAL(r_std),DIMENSION(kjpindex,nvm)          :: vcmax
+    REAL(r_std),DIMENSION(kjpindex,nvm)          :: vjmax
+    ! Min temperature for photosynthesis (deg C)
+    REAL(r_std),DIMENSION(kjpindex,nvm)         :: t_photo_min
+    ! Opt temperature for photosynthesis (deg C)
+    REAL(r_std),DIMENSION(kjpindex,nvm)         :: t_photo_opt
+    ! Max temperature for photosynthesis (deg C)
+    REAL(r_std),DIMENSION(kjpindex,nvm)         :: t_photo_max
+    ! Index
+    INTEGER(i_std)                              :: j
+    !---------------------------------------------------------------------
+
+    IF (control%ok_stomate) THEN
+       !
+       ! 1 photosynthesis parameters
+       !
+       !
+       ! 1.1 vcmax
+       !     only if STOMATE is activated
+       !
+       CALL vmax (kjpindex, dt_0, leaf_age, leaf_frac, vcmax, vjmax)
+       !
+       ! 1.2 assimilation temperatures
+       !
+       CALL assim_temp(kjpindex, tlong_ref, t2m_month, &
+            &                    t_photo_min, t_photo_opt, t_photo_max)
+       !
+       ! 1.3 transform into nvm vegetation types
+       !
+       assim_param(:,:,ivcmax) = zero
+
+       DO j = 2, nvm
+          assim_param(:,j,ivcmax)=vcmax(:,j)
+       ENDDO
+
+       assim_param(:,:,ivjmax) = zero
+
+       DO j = 2, nvm
+          assim_param(:,j,ivjmax)=vjmax(:,j)
+       ENDDO
+
+       assim_param(:,:,itmin) = zero
+
+       DO j = 2, nvm
+          assim_param(:,j,itmin)=t_photo_min(:,j)
+       ENDDO
+
+       assim_param(:,:,itopt) = zero
+
+       DO j = 2, nvm
+          assim_param(:,j,itopt)=t_photo_opt(:,j)
+       ENDDO
+
+       assim_param(:,:,itmax) = zero
+
+       DO j = 2, nvm
+          assim_param(:,j,itmax)=t_photo_max(:,j)
+       ENDDO
+
+       !
+       ! 2 dead leaf cover
+       !
+       ! edit shilong      
+       !      CALL deadleaf (kjpindex, dead_leaves, deadleaf_cover)
+       CALL deadleaf (kjpindex, veget_cov_max, dead_leaves, deadleaf_cover)     
+       !
+       ! 3 qsintmax
+       !
+       qsintmax(:,ibare_sechiba) = zero
+       DO j=2,nvm
+          qsintmax(:,j) = qsintcst*veget(:,j)*lai(:,j)
+       ENDDO
+
+    ENDIF ! ok_stomate = .TRUE.
+    !--------------------------------
+  END SUBROUTINE stomate_var_init
+  !
+  !=
+  !
+  SUBROUTINE stomate_accu &
+       &  (npts, n_dim2, dt_tot, dt, ldmean, field_in, field_out)
+    !---------------------------------------------------------------------
+    !
+    ! 0 declarations
+    !
+    ! 0.1 input
+    !
+    ! Domain size
+    INTEGER(i_std),INTENT(in)                       :: npts
+    ! 2nd dimension (1 or nvm)
+    INTEGER(i_std),INTENT(in)                       :: n_dim2
+    ! Time step of STOMATE (days)
+    REAL(r_std),INTENT(in)                           :: dt_tot
+    ! Time step in days
+    REAL(r_std),INTENT(in)                           :: dt
+    ! Calculate mean ?
+    LOGICAL,INTENT(in)                              :: ldmean
+    ! Daily field
+    REAL(r_std),DIMENSION(npts,n_dim2),INTENT(in)    :: field_in
+    !
+    ! 0.2 modified field
+    !
+    ! Annual field
+    REAL(r_std),DIMENSION(npts,n_dim2),INTENT(inout) :: field_out
+    !---------------------------------------------------------------------
+    !
+    ! 1 accumulation
+    !
+    field_out(:,:) = field_out(:,:)+field_in(:,:)*dt
+    !
+    ! 2 mean fields
+    !
+    IF (ldmean) THEN
+       field_out(:,:) = field_out(:,:)/dt_tot
+    ENDIF
+    !---------------------------------------------------------------------
+  END SUBROUTINE stomate_accu
+
+  SUBROUTINE init_forcing (kjpindex,nsfm,nsft)
+    !---------------------------------------------------------------------
+    INTEGER(i_std),INTENT(in) :: kjpindex
+    INTEGER(i_std),INTENT(in) :: nsfm
+    INTEGER(i_std),INTENT(in) :: nsft
+    !
+    LOGICAL        :: l_error
+    INTEGER(i_std) :: ier
+    !---------------------------------------------------------------------
+    l_error = .FALSE.
+    !
+    ALLOCATE(clay_fm(kjpindex,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(humrel_daily_fm(kjpindex,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(litterhum_daily_fm(kjpindex,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_daily_fm(kjpindex,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(t2m_min_daily_fm(kjpindex,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(tsurf_daily_fm(kjpindex,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(tsoil_daily_fm(kjpindex,nbdl,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(soilhum_daily_fm(kjpindex,nbdl,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(precip_fm(kjpindex,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(gpp_daily_fm(kjpindex,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(resp_maint_part_fm(kjpindex,nvm,nparts,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(veget_fm(kjpindex,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(veget_max_fm(kjpindex,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(lai_fm(kjpindex,nvm,nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(isf(nsfm),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(nf_written(nsft),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+    ALLOCATE(nf_cumul(nsft),stat=ier)
+    l_error = l_error .OR. (ier /= 0)
+
+    IF (is_root_prc) THEN
+       ALLOCATE(clay_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(humrel_daily_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(litterhum_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(t2m_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(t2m_min_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(tsurf_daily_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(tsoil_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(soilhum_daily_fm_g(nbp_glo,nbdl,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(precip_fm_g(nbp_glo,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(gpp_daily_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(resp_maint_part_fm_g(nbp_glo,nvm,nparts,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(veget_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(veget_max_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+       ALLOCATE(lai_fm_g(nbp_glo,nvm,nsfm),stat=ier)
+       l_error = l_error .OR. (ier /= 0)
+    ENDIF
+    !
+    IF (l_error) THEN
+       WRITE(numout,*) 'Problem with memory allocation: forcing variables'
+       STOP 'init_forcing'
+    ENDIF
+    !
+    CALL forcing_zero
+    !--------------------------
+  END SUBROUTINE init_forcing
+  !
+  !=
+  !
+  SUBROUTINE forcing_zero
+    !---------------------------------------------------------------------
+    clay_fm(:,:) = zero
+    humrel_daily_fm(:,:,:) = zero
+    litterhum_daily_fm(:,:) = zero
+    t2m_daily_fm(:,:) = zero
+    t2m_min_daily_fm(:,:) = zero
+    tsurf_daily_fm(:,:) = zero
+    tsoil_daily_fm(:,:,:) = zero
+    soilhum_daily_fm(:,:,:) = zero
+    precip_fm(:,:) = zero
+    gpp_daily_fm(:,:,:) = zero
+    resp_maint_part_fm(:,:,:,:)=zero
+    veget_fm(:,:,:) = zero
+    veget_max_fm(:,:,:) = zero
+    lai_fm(:,:,:) = zero
+    !--------------------------------
+  END SUBROUTINE forcing_zero
+  !
+  !=
+  !
+  SUBROUTINE forcing_write(forcing_id,ibeg,iend)
+    !---------------------------------------------------------------------
+    INTEGER(i_std),INTENT(in)  :: forcing_id
+    INTEGER(i_std),INTENT(in)  :: ibeg, iend
+    !
+    INTEGER(i_std)                 :: iisf, iblocks, nblocks
+    INTEGER(i_std)                 :: ier
+    INTEGER(i_std),DIMENSION(0:2)  :: ifirst, ilast
+    INTEGER(i_std),PARAMETER       :: ndm = 10
+    INTEGER(i_std),DIMENSION(ndm)  :: start, count_force
+    INTEGER(i_std)                 :: ndim, vid
+    !---------------------------------------------------------------------
+    !
+    ! determine blocks of forcing states that are contiguous in memory
+    !
+    nblocks = 0
+    ifirst(:) = 1
+    ilast(:) = 1
+    !
+    DO iisf = ibeg, iend
+       IF (     (nblocks /= 0) &
+            &      .AND.(isf(iisf) == isf(ilast(nblocks))+1)) THEN
+          ! element is contiguous with last element found
+          ilast(nblocks) = iisf
+       ELSE
+          ! found first element of new block
+          nblocks = nblocks+1
+          IF (nblocks > 2)  STOP 'Problem in forcing_write'
+          ifirst(nblocks) = iisf
+          ilast(nblocks) = iisf
+       ENDIF
+    ENDDO
+    !
+    CALL gather(clay_fm,clay_fm_g)
+    CALL gather(humrel_daily_fm,humrel_daily_fm_g)
+    CALL gather(litterhum_daily_fm,litterhum_daily_fm_g)
+    CALL gather(t2m_daily_fm,t2m_daily_fm_g)
+    CALL gather(t2m_min_daily_fm,t2m_min_daily_fm_g)
+    CALL gather(tsurf_daily_fm,tsurf_daily_fm_g)
+    CALL gather(tsoil_daily_fm,tsoil_daily_fm_g)
+    CALL gather(soilhum_daily_fm,soilhum_daily_fm_g)
+    CALL gather(precip_fm,precip_fm_g)
+    CALL gather(gpp_daily_fm,gpp_daily_fm_g)
+    CALL gather(resp_maint_part_fm,resp_maint_part_fm_g)
+    CALL gather(veget_fm,veget_fm_g)
+    CALL gather(veget_max_fm,veget_max_fm_g)
+    CALL gather(lai_fm,lai_fm_g)
+    IF (is_root_prc) THEN
+       DO iblocks = 1, nblocks
+          IF (ifirst(iblocks) /= ilast(iblocks)) THEN
+             ndim = 2
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(clay_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'clay',vid)
+             ier = NF90_PUT_VAR (forcing_id,vid, &
+                  &              clay_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(humrel_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'humrel',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            humrel_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(litterhum_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'litterhum',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            litterhum_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(t2m_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'t2m',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            t2m_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(t2m_min_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'t2m_min',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            t2m_min_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(tsurf_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'tsurf',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            tsurf_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(tsoil_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'tsoil',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            tsoil_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(soilhum_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'soilhum',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            soilhum_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(precip_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'precip',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            precip_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  & start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(gpp_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'gpp',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            gpp_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 4;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim)=SHAPE(resp_maint_part_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'resp_maint_part',vid)
+             ier = NF90_PUT_VAR (forcing_id,vid, &
+                  &            resp_maint_part_fm_g(:,:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(veget_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'veget',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            veget_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(veget_max_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'veget_max',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            veget_max_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(lai_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'lai',vid)
+             ier = NF90_PUT_VAR (forcing_id, vid, &
+                  &            lai_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+          ENDIF
+       ENDDO
+    ENDIF
+    nf_written(isf(:)) = .TRUE.
+    !---------------------------
+  END SUBROUTINE forcing_write
+  !
+  !=
+  !
+  SUBROUTINE forcing_read(forcing_id,nsfm)
+    !---------------------------------------------------------------------
+    INTEGER(i_std),INTENT(in) :: forcing_id
+    INTEGER(i_std),INTENT(in) :: nsfm
+    !
+    INTEGER(i_std)                :: iisf, iblocks, nblocks
+    INTEGER(i_std)                :: ier
+    INTEGER(i_std),DIMENSION(0:2) :: ifirst, ilast
+    INTEGER(i_std),PARAMETER      :: ndm = 10
+    INTEGER(i_std),DIMENSION(ndm) :: start, count_force
+    INTEGER(i_std)                :: ndim, vid
+    !---------------------------------------------------------------------
+    !
+    ! set to zero if the corresponding forcing state
+    ! has not yet been written into the file
+    !
+    DO iisf = 1, nsfm
+       IF (.NOT.nf_written(isf(iisf))) THEN
+          clay_fm(:,iisf) = zero
+          humrel_daily_fm(:,:,iisf) = zero
+          litterhum_daily_fm(:,iisf) = zero
+          t2m_daily_fm(:,iisf) = zero
+          t2m_min_daily_fm(:,iisf) = zero
+          tsurf_daily_fm(:,iisf) = zero
+          tsoil_daily_fm(:,:,iisf) = zero
+          soilhum_daily_fm(:,:,iisf) = zero
+          precip_fm(:,iisf) = zero
+          gpp_daily_fm(:,:,iisf) = zero
+          resp_maint_part_fm(:,:,:,iisf) = zero
+          veget_fm(:,:,iisf) = zero
+          veget_max_fm(:,:,iisf) = zero
+          lai_fm(:,:,iisf) = zero
+       ENDIF
+    ENDDO
+    !
+    ! determine blocks of forcing states that are contiguous in memory
+    !
+    nblocks = 0
+    ifirst(:) = 1
+    ilast(:) = 1
+    !
+    DO iisf = 1, nsfm
+       IF (nf_written(isf(iisf))) THEN
+          IF (     (nblocks /= 0) &
+               &        .AND.(isf(iisf) == isf(ilast(nblocks))+1)) THEN
+             ! element is contiguous with last element found
+             ilast(nblocks) = iisf
+          ELSE
+             ! found first element of new block
+             nblocks = nblocks+1
+             IF (nblocks > 2)  STOP 'Problem in forcing_read'
+             !
+             ifirst(nblocks) = iisf
+             ilast(nblocks) = iisf
+          ENDIF
+       ENDIF
+    ENDDO
+    !
+    IF (is_root_prc) THEN
+       DO iblocks = 1, nblocks
+          IF (ifirst(iblocks) /= ilast(iblocks)) THEN
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(clay_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'clay',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            clay_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(humrel_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'humrel',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            humrel_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(litterhum_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'litterhum',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              litterhum_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(t2m_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'t2m',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              t2m_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(t2m_min_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'t2m_min',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              t2m_min_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(tsurf_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'tsurf',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              tsurf_daily_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(tsoil_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'tsoil',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              tsoil_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(soilhum_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'soilhum',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              soilhum_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 2;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(precip_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'precip',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &              precip_fm_g(:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(gpp_daily_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'gpp',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            gpp_daily_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 4;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim)=SHAPE(resp_maint_part_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'resp_maint_part',vid)
+             ier = NF90_GET_VAR (forcing_id,vid, &
+                  &       resp_maint_part_fm_g(:,:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(veget_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'veget',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            veget_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(veget_max_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'veget_max',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            veget_max_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+             ndim = 3;
+             start(1:ndim) = 1; start(ndim) = isf(ifirst(iblocks));
+             count_force(1:ndim) = SHAPE(lai_fm_g)
+             count_force(ndim) = isf(ilast(iblocks))-isf(ifirst(iblocks))+1
+             ier = NF90_INQ_VARID (forcing_id,'lai',vid)
+             ier = NF90_GET_VAR (forcing_id, vid, &
+                  &            lai_fm_g(:,:,ifirst(iblocks):ilast(iblocks)), &
+                  &            start=start(1:ndim), count=count_force(1:ndim))
+          ENDIF
+       ENDDO
+    ENDIF
+    CALL scatter(clay_fm_g,clay_fm)
+    CALL scatter(humrel_daily_fm_g,humrel_daily_fm)
+    CALL scatter(litterhum_daily_fm_g,litterhum_daily_fm)
+    CALL scatter(t2m_daily_fm_g,t2m_daily_fm)
+    CALL scatter(t2m_min_daily_fm_g,t2m_min_daily_fm)
+    CALL scatter(tsurf_daily_fm_g,tsurf_daily_fm)
+    CALL scatter(tsoil_daily_fm_g,tsoil_daily_fm)
+    CALL scatter(soilhum_daily_fm_g,soilhum_daily_fm)
+    CALL scatter(precip_fm_g,precip_fm)
+    CALL scatter(gpp_daily_fm_g,gpp_daily_fm)
+    CALL scatter(resp_maint_part_fm_g,resp_maint_part_fm)
+    CALL scatter(veget_fm_g,veget_fm)
+    CALL scatter(veget_max_fm_g,veget_max_fm)
+    CALL scatter(lai_fm_g,lai_fm_g)
+    !--------------------------
+  END SUBROUTINE forcing_read
+  !
+  !=
+  !
+  SUBROUTINE setlai(npts,lai)
+    !---------------------------------------------------------------------
+    ! routine to force the lai in STOMATE (for assimilation procedures)
+    ! for the moment setlai only gives the lai from stomate,
+    ! this routine must be written in the future
+    !
+    ! 0 declarations
+    !
+    ! 0.1 input
+    !
+    ! Domain size
+    INTEGER(i_std),INTENT(in)                    :: npts
+    ! 0.3 output
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out)  :: lai
+    ! 0.4 local definitions
+    INTEGER(i_std)                               :: j
+    !---------------------------------------------------------------------
+    lai(:,ibare_sechiba) = zero
+    DO j=2,nvm
+       lai(:,j) = biomass(:,j,ileaf)*sla(j)
+    ENDDO
+    !--------------------
+  END SUBROUTINE setlai
+  !
+  !
+  !-----------------
+END MODULE stomate
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_alloc.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_alloc.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_alloc.f90	(revision 55)
@@ -0,0 +1,573 @@
+! allocation to the roots, stems, leaves, "fruits" and carbohydrate reserve.
+! Reproduction: for the moment, this is simply a 10% "tax".
+! This should depend on the limitations that the plant experiences. If the
+! plant fares well, it will have fruits. However, this means that we should
+! also "reward" the plants for having grown fruits by making the
+! reproduction rate depend on the fruit growth of the past years. Otherwise,
+! the fruit allocation would be a punishment for plants that are doing well.
+! "calculates" root profiles (in fact, prescribes it for the moment).
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_alloc.f90,v 1.10 2009/03/31 12:11:22 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_alloc
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC alloc,alloc_clear
+
+  ! first call
+  LOGICAL, SAVE                                             :: firstcall = .TRUE.
+CONTAINS
+  SUBROUTINE alloc_clear
+    firstcall = .TRUE.
+  END SUBROUTINE alloc_clear
+
+  SUBROUTINE alloc (npts, dt, &
+       lai, veget_max, senescence, when_growthinit, &
+       moiavail_week, tsoil_month, soilhum_month, &
+       biomass, age, leaf_age, leaf_frac, rprof, f_alloc)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                       :: npts
+    ! time step (days)
+    REAL(r_std), INTENT(in)                                    :: dt
+    ! Leaf area index
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lai
+    ! "maximal" coverage fraction of a PFT ( = ind*cn_ind )
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: veget_max
+    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                 :: senescence
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: when_growthinit
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: moiavail_week
+    ! "monthly" soil temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)              :: tsoil_month
+    ! "monthly" soil humidity
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)              :: soilhum_month
+    !  age (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: age
+
+    ! 0.2 modified fields
+
+    ! biomass (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)    :: biomass
+    ! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout) :: leaf_frac
+
+    ! 0.3 output
+
+    ! root depth. This will, one day, be a prognostic variable. It will be calculated by
+    ! STOMATE (save in restart file & give to hydrology module!). For the moment, it
+    ! is prescribed.
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)             :: rprof
+    ! fraction that goes into plant part
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)      :: f_alloc
+
+    ! 0.4 local
+
+    ! Do we try to reach a minimum reservoir even if we are severely stressed?
+    LOGICAL, PARAMETER                                        :: ok_minres = .TRUE.
+    ! time (d) to attain the initial foliage using the carbohydrate reserve
+    REAL(r_std), PARAMETER                                     :: tau_leafinit = 10.
+    ! maximum time (d) during which reserve is used (trees)
+    REAL(r_std), PARAMETER                                     :: reserve_time_tree = 30.
+    ! maximum time (d) during which reserve is used (grasses)
+    REAL(r_std), PARAMETER                                     :: reserve_time_grass = 20.
+    ! Standard root allocation
+    REAL(r_std), PARAMETER                                     :: R0 = 0.3
+    ! Standard sapwood allocation
+    REAL(r_std), PARAMETER                                     :: S0 = 0.3
+    ! Standard leaf allocation
+    REAL(r_std), PARAMETER                                     :: L0 = un - R0 - S0
+    ! Standard fruit allocation
+    REAL(r_std), PARAMETER                                     :: f_fruit = 0.1
+    ! fraction of sapwood allocation above ground (SHOULD BE CALCULATED !!!!)
+    REAL(r_std), PARAMETER                                     :: alloc_sap_above_tree = 0.5
+    REAL(r_std), PARAMETER                                     :: alloc_sap_above_grass = un
+    ! extrema of leaf allocation fraction
+    REAL(r_std), PARAMETER                                     :: min_LtoLSR = 0.2
+    REAL(r_std), PARAMETER                                     :: max_LtoLSR = 0.5
+    ! below this lai, the carbohydrate reserve is used
+    REAL(r_std), DIMENSION(nvm)                               :: lai_happy
+    ! limiting factor light
+    REAL(r_std), DIMENSION(npts)                               :: limit_L
+    ! limiting factor nitrogen
+    REAL(r_std), DIMENSION(npts)                               :: limit_N
+    ! factors determining limit_N: 1/ temperature
+    REAL(r_std), DIMENSION(npts)                               :: limit_N_temp
+    ! factors determining limit_N: 2/ humidity
+    REAL(r_std), DIMENSION(npts)                               :: limit_N_hum
+    ! limiting factor water
+    REAL(r_std), DIMENSION(npts)                               :: limit_W
+    ! limiting factor in soil (nitrogen or water)
+    REAL(r_std), DIMENSION(npts)                               :: limit_WorN
+    ! limit: strongest limitation amongst limit_N, limit_W and limit_L
+    REAL(r_std), DIMENSION(npts)                               :: limit
+    ! scaling depth for nitrogen limitation (m)
+    REAL(r_std), PARAMETER                                     :: z_nitrogen = 0.2
+    ! soil temperature used for N parameterization
+    REAL(r_std), DIMENSION(npts)                               :: t_nitrogen
+    ! soil humidity used for N parameterization
+    REAL(r_std), DIMENSION(npts)                               :: h_nitrogen
+    ! integration constant for vertical profiles
+    REAL(r_std), DIMENSION(npts)                               :: rpc
+    ! ratio between leaf-allocation and (leaf+sapwood+root)-allocation
+    REAL(r_std), DIMENSION(npts)                               :: LtoLSR
+    ! ratio between sapwood-allocation and (leaf+sapwood+root)-allocation
+    REAL(r_std), DIMENSION(npts)                               :: StoLSR
+    ! ratio between root-allocation and (leaf+sapwood+root)-allocation
+    REAL(r_std), DIMENSION(npts)                               :: RtoLSR
+    ! rescaling factor for carbohydrate reserve allocation
+    REAL(r_std), DIMENSION(npts)                               :: carb_rescale
+    ! mass taken from carbohydrate reserve (gC/m**2)
+    REAL(r_std), DIMENSION(npts)                               :: use_reserve
+    ! mass taken from carbohydrate reserve and put into leaves (gC/m**2)
+    REAL(r_std), DIMENSION(npts)                               :: transloc_leaf
+    ! mass in youngest leaf age class (gC/m**2)
+    REAL(r_std), DIMENSION(npts)                               :: leaf_mass_young
+    ! old leaf biomass (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm)                          :: lm_old
+    ! maximum time (d) during which reserve is used
+    REAL(r_std)                                                :: reserve_time
+    ! lai on natural part of the grid cell, or of this agricultural PFT
+    REAL(r_std), DIMENSION(npts,nvm)                          :: lai_around
+    ! vegetation cover of natural PFTs on the grid cell (agriculture masked)
+    REAL(r_std), DIMENSION(npts,nvm)                          :: veget_max_nat 
+    ! total natural vegetation cover on natural part of the grid cell
+    REAL(r_std), DIMENSION(npts)                               :: natveg_tot
+    ! average LAI on natural part of the grid cell
+    REAL(r_std), DIMENSION(npts)                               :: lai_nat
+    ! intermediate array for looking for minimum
+    REAL(r_std), DIMENSION(npts)                               :: zdiff_min
+    ! fraction of sapwood allocation above ground (SHOULD BE CALCULATED !!!!)
+    REAL(r_std), DIMENSION(npts)                               :: alloc_sap_above
+    ! soil levels (m)
+    REAL(r_std), SAVE, DIMENSION(0:nbdl)                       :: z_soil
+    ! Index
+    INTEGER(i_std)                                            :: i,j,l,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering alloc'
+
+    !
+    ! 1 Initialization
+    !
+
+    !
+    ! 1.1 first call
+    !
+
+    IF ( firstcall ) THEN
+
+       ! 1.1.1 soil levels
+
+       z_soil(0) = zero
+       z_soil(1:nbdl) = diaglev(1:nbdl)
+
+       ! 1.1.2 info about flags and parameters.
+
+       WRITE(numout,*) 'alloc:'
+
+       WRITE(numout,'(a,$)') '    > We'
+       IF ( .NOT. ok_minres ) WRITE(numout,'(a,$)') ' do NOT'
+       WRITE(numout,*) 'try to reach a minumum reservoir when severely stressed.'
+
+       WRITE(numout,*) '   > Time to put initial leaf mass on (d): ',tau_leafinit
+
+       WRITE(numout,*) '   > scaling depth for nitrogen limitation (m): ', &
+            z_nitrogen
+
+       WRITE(numout,*) '   > sap allocation above the ground / total sap allocation: '
+       WRITE(numout,*) '       trees:', alloc_sap_above_tree
+       WRITE(numout,*) '       grasses:', alloc_sap_above_grass
+
+       WRITE(numout,*) '   > standard root alloc fraction: ', R0
+
+       WRITE(numout,*) '   > standard sapwood alloc fraction: ', S0
+
+       WRITE(numout,*) '   > standard fruit allocation: ', f_fruit
+
+       WRITE(numout,*) '   > minimum/maximum leaf alloc fraction: ', min_LtoLSR,max_LtoLSR
+
+       WRITE(numout,*) '   > maximum time (d) during which reserve is used:'
+       WRITE(numout,*) '       trees:',reserve_time_tree
+       WRITE(numout,*) '       grasses:',reserve_time_grass
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 initialize output
+    !
+
+    f_alloc(:,:,:) = zero
+    f_alloc(:,:,icarbres) = un
+    !
+    ! 1.3 Convolution of the temperature and humidity profiles with some kind of profile
+    !     of microbial density gives us a representative temperature and humidity 
+    !
+
+    ! 1.3.1 temperature
+
+    ! 1.3.1.1 rpc is an integration constant such that the integral of the root profile is 1.
+    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_nitrogen ) )
+
+    ! 1.3.1.2 integrate over the nbdl levels
+
+    t_nitrogen(:) = 0.
+
+    DO l = 1, nbdl
+
+       t_nitrogen(:) = &
+            t_nitrogen(:) + tsoil_month(:,l) * rpc(:) * &
+            ( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
+
+    ENDDO
+
+    ! 1.3.2 moisture
+
+    ! 1.3.2.1 rpc is an integration constant such that the integral of the root profile is 1.
+    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_nitrogen ) )
+
+    ! 1.3.2.2 integrate over the nbdl levels
+
+    h_nitrogen(:) = zero
+
+    DO l = 1, nbdl
+
+       h_nitrogen(:) = &
+            h_nitrogen(:) + soilhum_month(:,l) * rpc(:) * &
+            ( EXP( -z_soil(l-1)/z_nitrogen ) - EXP( -z_soil(l)/z_nitrogen ) )
+
+    ENDDO
+
+    !
+    ! 1.4 for light limitation: lai on natural part of the grid cell or lai of this
+    !       agricultural PFT
+    !
+
+    ! mask agricultural vegetation
+    ! mean LAI on natural part
+
+    natveg_tot(:) = zero
+    lai_nat(:) = zero
+
+    DO j = 2, nvm
+
+       IF ( natural(j) ) THEN
+          veget_max_nat(:,j) = veget_max(:,j)
+       ELSE
+          veget_max_nat(:,j) = zero
+       ENDIF
+
+       ! sum up fraction of natural space covered by vegetation
+       natveg_tot(:) = natveg_tot(:) + veget_max_nat(:,j)
+
+       ! sum up lai
+       lai_nat(:) = lai_nat(:) + veget_max_nat(:,j) * lai(:,j)
+
+    ENDDO
+
+    DO j = 2, nvm
+
+       IF ( natural(j) ) THEN
+          lai_around(:,j) = lai_nat(:)
+       ELSE
+          lai_around(:,j) = lai(:,j)
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 1.5 LAI below which carbohydrate reserve is used
+    !
+
+    lai_happy(:) = lai_max(:) * 0.5
+
+    !
+    ! 2 Use carbohydrate reserve
+    !   This time constant implicitly takes into account the dispersion of the budburst
+    !   data. Therefore, it might be decreased at lower resolution.
+    !
+
+    ! save old leaf mass
+
+    lm_old(:,:) = biomass(:,:,ileaf)
+
+    DO j = 2, nvm
+
+       !
+       ! 2.1 determine mass to be translocated to leaves and roots
+       !
+
+       ! determine maximum time during which reserve is used
+
+       IF ( tree(j) ) THEN
+          reserve_time = reserve_time_tree
+       ELSE
+          reserve_time = reserve_time_grass
+       ENDIF
+
+       ! conditions: 1/ plant must not be senescent
+       !             2/ lai must be relatively low
+       !             3/ must be at the beginning of the growing season
+
+       WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. & 
+            ( .NOT. senescence(:,j) ) .AND. &
+            ( lai(:,j) .LT. lai_happy(j) ) .AND. &
+            ( when_growthinit(:,j) .LT. reserve_time ) ) 
+
+          ! determine mass to put on
+          use_reserve(:) = &
+               MIN( biomass(:,j,icarbres), &
+               2._r_std * dt/tau_leafinit * lai_happy(j)/ sla(j) )
+
+          ! grow leaves and fine roots
+
+          transloc_leaf(:) = L0/(L0+R0) * use_reserve(:)
+
+          biomass(:,j,ileaf) = biomass(:,j,ileaf) + transloc_leaf(:)
+          biomass(:,j,iroot) = biomass(:,j,iroot) + ( use_reserve(:) - transloc_leaf(:) )
+
+          ! decrease reserve mass
+
+          biomass(:,j,icarbres) = biomass(:,j,icarbres) - use_reserve(:)
+
+       ELSEWHERE
+
+          transloc_leaf(:) = zero
+
+       ENDWHERE
+
+       !
+       ! 2.2 update leaf age
+       !
+
+       ! 2.2.1 Decrease leaf age in youngest class.
+
+       leaf_mass_young(:) = leaf_frac(:,j,1) * lm_old(:,j) + transloc_leaf(:)
+
+       WHERE ( ( transloc_leaf(:) .GT. min_stomate ) .AND. ( leaf_mass_young(:) .GT. min_stomate ) )
+
+          leaf_age(:,j,1) = MAX( zero, leaf_age(:,j,1) * ( leaf_mass_young(:) - transloc_leaf(:) ) / &
+               leaf_mass_young(:) )
+
+       ENDWHERE
+
+       ! 2.2.2 new age class fractions (fraction in youngest class increases)
+
+       ! 2.2.2.1 youngest class: new mass in youngest class divided by total new mass
+
+       WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
+
+          leaf_frac(:,j,1) = leaf_mass_young(:) / biomass(:,j,ileaf)
+
+       ENDWHERE
+
+       ! 2.2.2.2 other classes: old mass in leaf age class divided by new mass
+
+       DO m = 2, nleafages
+
+          WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
+
+             leaf_frac(:,j,m) = leaf_frac(:,j,m) * lm_old(:,j) / biomass(:,j,ileaf)
+
+          ENDWHERE
+
+       ENDDO
+
+    ENDDO         ! loop over PFTs
+
+    !
+    ! 3 Calculate fractional allocation.
+    !   The fractions of NPP allocated to the different compartments depend on the
+    !   availability of light, water, and nitrogen.
+    !
+
+    DO j = 2, nvm
+
+       RtoLSR(:)=0
+       LtoLSR(:)=0
+       StoLSR(:)=0
+
+       ! for the moment, fixed partitioning between above and below the ground
+       ! modified by JO/NV/PF for changing partitioning with stand age
+       ! we could have alloc_sap_above(npts,nvm) but we have only
+       ! alloc_sap_above(npts) as we make a loop over j=2,nvm
+       !
+       IF ( tree(j) ) THEN
+
+          alloc_sap_above (:) = alloc_min(j)+(alloc_max(j)-alloc_min(j))*(1.-EXP(-age(:,j)/demi_alloc(j)))
+
+          !IF (j .EQ. 3) WRITE(*,*) '%allocated above = 'alloc_sap_above(1),'age = ',age(1,j)
+       ELSE
+          alloc_sap_above(:) = alloc_sap_above_grass
+       ENDIF
+
+       ! only where leaves are on
+
+       WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
+
+          !
+          ! 3.1 Limiting factors: weak value = strong limitation
+          !
+
+          ! 3.1.1 Light: depends on mean lai on the natural part of the
+          !       grid box (light competition).
+          !       For agricultural PFTs, take its own lai for both parts.
+          !MM, NV
+          WHERE( lai_around(:,j) < 10 )
+             limit_L(:) = MAX( 0.1_r_std, EXP( -0.5_r_std * lai_around(:,j) ) )
+          ELSEWHERE
+             limit_L(:) = 0.1_r_std
+          ENDWHERE
+          ! 3.1.2 Water
+
+          limit_W(:) = MAX( 0.1_r_std, MIN( 1._r_std, moiavail_week(:,j) ) )
+
+          ! 3.1.3 Nitrogen supply: depends on water and temperature
+          !       Agricultural PFTs can be limited by Nitrogen for the moment ...
+          !       Replace this once there is a nitrogen cycle in STOMATE !
+
+          ! 3.1.3.1 water 
+
+          limit_N_hum(:) = MAX( 0.5_r_std, MIN( 1._r_std, h_nitrogen(:) ) )
+
+          ! 3.1.3.2 temperature
+
+          limit_N_temp(:) = 2.**((t_nitrogen(:)-ZeroCelsius-25.)/10.)
+          limit_N_temp(:) = MAX( 0.1_r_std, MIN( 1._r_std, limit_N_temp(:) ) )
+
+          ! 3.1.3.3 combine water and temperature factors to get nitrogen limitation
+
+          limit_N(:) = MAX( 0.1_r_std, MIN( 1._r_std, limit_N_hum(:) * limit_N_temp(:) ) )
+
+          ! 3.1.4 Among water and nitrogen, take the one that is more limited
+
+          limit_WorN(:) = MIN( limit_W(:), limit_N(:) )
+
+          ! 3.1.5 strongest limitation
+
+          limit(:) = MIN( limit_WorN(:), limit_L(:) )
+
+          !
+          ! 3.2 Ratio between allocation to leaves, sapwood and roots
+          !
+
+          ! preliminary root allocation
+
+          RtoLSR(:) = &
+               MAX( .15_r_std, &
+               R0 * 3._r_std * limit_L(:) / ( limit_L(:) + 2._r_std * limit_WorN(:) ) )
+
+          ! sapwood allocation
+
+          StoLSR(:) = S0 * 3. * limit_WorN(:) / ( 2. * limit_L(:) + limit_WorN(:) )
+
+          ! leaf allocation
+
+          LtoLSR(:) = un - RtoLSR(:) - StoLSR(:)
+          LtoLSR(:) = MAX( min_LtoLSR, MIN( max_LtoLSR, LtoLSR(:) ) )
+
+          ! roots: the rest
+
+          RtoLSR(:) = un - LtoLSR(:) - StoLSR(:)
+
+       ENDWHERE
+
+       ! no leaf allocation if LAI beyond maximum LAI. Biomass then goes into sapwood
+
+       WHERE ( (biomass(:,j,ileaf) .GT. min_stomate) .AND. (lai(:,j) .GT. lai_max(j)) )
+
+          StoLSR(:) = StoLSR(:) + LtoLSR(:)
+
+          LtoLSR(:) = zero
+
+       ENDWHERE
+
+       !
+       ! 3.3 final allocation
+       !
+
+       DO i = 1, npts
+
+          IF ( biomass(i,j,ileaf) .GT. min_stomate ) THEN
+
+             IF ( senescence(i,j) ) THEN
+
+                ! 3.3.1 senescent: everything goes into carbohydrate reserve
+
+                f_alloc(i,j,icarbres) = 1.0
+
+             ELSE
+
+                ! 3.3.2 in growing season
+
+                ! to fruits
+                f_alloc(i,j,ifruit) = f_fruit
+
+                ! allocation to the reserve is proportional to the leaf and root allocation.
+                ! Leaf, root, and sap allocation are rescaled.
+                ! No allocation to reserve if there is much biomass in it 
+                !   (more than the maximum LAI: in that case, rescale=1)
+
+                IF ( ( biomass(i,j,icarbres)*sla(j) ) .LT. 2*lai_max(j) ) THEN
+                   carb_rescale(i) = un / ( un + ecureuil(j) * ( LtoLSR(i) + RtoLSR(i) ) )
+                ELSE
+                   carb_rescale(i) = un
+                ENDIF
+
+                f_alloc(i,j,ileaf) = LtoLSR(i) * ( 1.-f_alloc(i,j,ifruit) ) * carb_rescale(i)
+
+                f_alloc(i,j,isapabove) = StoLSR(i) * alloc_sap_above(i) * &
+                     ( un - f_alloc(i,j,ifruit) ) * carb_rescale(i)
+                f_alloc(i,j,isapbelow) = StoLSR(i) * ( un - alloc_sap_above(i) ) * &
+                     ( un - f_alloc(i,j,ifruit) ) * carb_rescale(i)
+
+                f_alloc(i,j,iroot) = RtoLSR(i) * ( 1.-f_alloc(i,j,ifruit) ) * carb_rescale(i)
+
+                ! this is equivalent to:
+                ! reserve alloc = ecureuil*(LtoLSR+StoLSR)*(1-fruit_alloc)*carb_rescale
+                f_alloc(i,j,icarbres) = ( un - carb_rescale(i) ) * ( 1.-f_alloc(i,j,ifruit) )
+
+             ENDIF  ! senescent?
+
+          ENDIF    ! there are leaves
+
+       ENDDO      ! Fortran95: double WHERE construct
+
+    ENDDO          ! loop over PFTs
+
+    !
+    ! 4 root profile
+    !
+
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving alloc'
+
+  END SUBROUTINE alloc
+
+
+END MODULE stomate_alloc
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_assimtemp.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_assimtemp.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_assimtemp.f90	(revision 55)
@@ -0,0 +1,79 @@
+! calculates the photosynthesis temperatures
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_assimtemp.f90,v 1.7 2009/01/06 17:18:32 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_assimtemp
+
+  ! modules used:
+
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC assim_temp
+
+CONTAINS
+
+  SUBROUTINE assim_temp (npts, tlong_ref, t2m_month, t_photo_min, t_photo_opt, t_photo_max)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                        :: npts
+    ! "long term" 2 meter reference temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_month
+
+    ! 0.2 output
+    ! Minimum temperature for photosynthesis (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: t_photo_min
+    ! Optimum temperature for photosynthesis (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: t_photo_opt
+    ! Maximum temperature for photosynthesis (K)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: t_photo_max
+
+    ! 0.3 local
+    ! "long term" 2 meter reference temperatures (deg C)
+    REAL(r_std), DIMENSION(npts)                                :: tl
+    ! Index
+    INTEGER(i_std)                                             :: j
+
+    ! =========================================================================
+
+    tl(:) = tlong_ref(:) - ZeroCelsius
+
+    DO j = 2,nvm
+
+       !
+       ! 1 normal case
+       !
+
+       t_photo_min(:,j) = t_photo%t_min_c(j) + t_photo%t_min_b(j)*tl(:) + t_photo%t_min_a(j)*tl(:)*tl(:) + ZeroCelsius
+       t_photo_opt(:,j) = t_photo%t_opt_c(j) + t_photo%t_opt_b(j)*tl(:) + t_photo%t_opt_a(j)*tl(:)*tl(:) + ZeroCelsius
+       t_photo_max(:,j) = t_photo%t_max_c(j) + t_photo%t_max_b(j)*tl(:) + t_photo%t_max_a(j)*tl(:)*tl(:) + ZeroCelsius
+
+       !
+       ! 2 If the monthly temperature is too low, we set tmax < tmin.
+       !   Therefore, photosynthesis will not be possible (we need tmin < t < tmax)
+       !
+
+       WHERE ( t2m_month(:) .LT. t_photo_min(:,j) )
+          t_photo_max(:,j) = t_photo_min(:,j) - min_stomate
+       ENDWHERE
+
+    ENDDO
+
+  END SUBROUTINE assim_temp
+
+END MODULE stomate_assimtemp
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_constants.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_constants.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_constants.f90	(revision 55)
@@ -0,0 +1,823 @@
+!$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_constants.f90,v 1.21 2010/05/17 14:25:41 ssipsl Exp $
+!IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!-
+MODULE stomate_constants
+!---------------------------------------------------------------------
+  USE defprec
+  USE constantes_veg
+  USE ioipsl  
+  USE parallel
+! bare soil in Sechiba
+  INTEGER(i_std),PARAMETER :: ibare_sechiba = 1
+!-
+! 0 = no, 4 = full online diagnostics
+  INTEGER(i_std),SAVE :: bavard=1
+! write forcing file for carbon spinup?
+  LOGICAL,SAVE :: write_carbonforce
+! Horizontal indices
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: hori_index
+! Horizonatal + PFT indices
+  INTEGER(i_std),ALLOCATABLE,SAVE,DIMENSION(:) :: horipft_index
+!-
+  ! Land cover change
+! Horizontal + P10 indices
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip10_index
+! Horizontal + P100 indices
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip100_index 
+! Horizontal + P11 indices
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip11_index
+! Horizontal + P101 indices
+  INTEGER(i_std), ALLOCATABLE, SAVE, DIMENSION(:) :: horip101_index 
+!-
+! time step
+  INTEGER(i_std),SAVE :: itime
+! STOMATE history file ID
+  INTEGER(i_std),SAVE :: hist_id_stomate
+! STOMATE history file ID for IPCC output
+  INTEGER(i_std),SAVE :: hist_id_stomate_IPCC
+! STOMATE restart file ID
+  INTEGER(i_std),SAVE :: rest_id_stomate
+!-
+! Freezing point
+  REAL(r_std),PARAMETER :: ZeroCelsius = 273.15
+! e
+  REAL(r_std),PARAMETER :: euler = 2.71828182846
+! Epsilon to detect a near zero floating point
+  REAL(r_std),PARAMETER :: min_stomate = 1.E-8_r_std
+! some large value
+  REAL(r_std),PARAMETER :: large_value = 1.E33_r_std
+! Special value
+  REAL(r_std),PARAMETER :: undef = -9999.
+!-
+! maximum reference long term temperature (K)
+  REAL(r_std),PARAMETER :: tlong_ref_max=303.1
+! minimum reference long term temperature (K)
+  REAL(r_std),PARAMETER :: tlong_ref_min=253.1
+!-
+! trees and litter: indices for the parts of heart- and sapwood above
+!   and below the ground
+  INTEGER(i_std),PARAMETER :: iabove = 1
+  INTEGER(i_std),PARAMETER :: ibelow = 2
+  INTEGER(i_std),PARAMETER :: nlevs = 2
+!-
+! litter: indices for metabolic and structural part
+  INTEGER(i_std),PARAMETER :: imetabolic = 1
+  INTEGER(i_std),PARAMETER :: istructural = 2
+  INTEGER(i_std),PARAMETER :: nlitt = 2
+!-
+! carbon pools: indices
+  INTEGER(i_std),PARAMETER :: iactive = 1
+  INTEGER(i_std),PARAMETER :: islow = 2
+  INTEGER(i_std),PARAMETER :: ipassive = 3
+  INTEGER(i_std),PARAMETER :: ncarb = 3
+!-
+! litter fractions: indices
+  INTEGER(i_std),PARAMETER :: ileaf = 1
+  INTEGER(i_std),PARAMETER :: isapabove = 2
+  INTEGER(i_std),PARAMETER :: isapbelow = 3
+  INTEGER(i_std),PARAMETER :: iheartabove = 4
+  INTEGER(i_std),PARAMETER :: iheartbelow = 5
+  INTEGER(i_std),PARAMETER :: iroot = 6
+  INTEGER(i_std),PARAMETER :: ifruit = 7
+  INTEGER(i_std),PARAMETER :: icarbres = 8
+  INTEGER(i_std),PARAMETER :: nparts = 8
+!-
+! transformation between types of surface
+  INTEGER(i_std),PARAMETER :: ito_natagri = 1
+  INTEGER(i_std),PARAMETER :: ito_total = 2
+!-
+! leaf age discretisation ( 1 = no discretisation )
+  INTEGER(i_std),PARAMETER :: nleafages = 4
+!-
+! alpha's : ?
+  REAL(r_std),PARAMETER :: alpha_grass = .5
+  REAL(r_std),PARAMETER :: alpha_tree = 1.
+!-
+! type declaration for photosynthesis
+  TYPE t_photo_type
+    REAL(r_std), DIMENSION(nvm)                  :: t_max_a
+    REAL(r_std), DIMENSION(nvm)                  :: t_max_b
+    REAL(r_std), DIMENSION(nvm)                  :: t_max_c
+    REAL(r_std), DIMENSION(nvm)                  :: t_opt_a
+    REAL(r_std), DIMENSION(nvm)                  :: t_opt_b
+    REAL(r_std), DIMENSION(nvm)                  :: t_opt_c
+    REAL(r_std), DIMENSION(nvm)                  :: t_min_a
+    REAL(r_std), DIMENSION(nvm)                  :: t_min_b
+    REAL(r_std), DIMENSION(nvm)                  :: t_min_c
+  END TYPE t_photo_type
+!-
+! type declaration for phenology
+  TYPE pheno_type
+    REAL(r_std), DIMENSION(nvm,3)                :: gdd
+    REAL(r_std), DIMENSION(nvm)                  :: ngd
+    REAL(r_std), DIMENSION(nvm)                  :: ncdgdd_temp
+    REAL(r_std), DIMENSION(nvm)                  :: hum_frac
+    REAL(r_std), DIMENSION(nvm)                  :: lowgpp_time
+    REAL(r_std), DIMENSION(nvm)                  :: leaffall
+    REAL(r_std), DIMENSION(nvm)                  :: leafagecrit
+    REAL(r_std)                       :: tau_hum_month
+    REAL(r_std)                       :: tau_hum_week
+    REAL(r_std)                       :: tau_t2m_month
+    REAL(r_std)                       :: tau_t2m_week
+    REAL(r_std)                       :: tau_tsoil_month
+    REAL(r_std)                       :: tau_soilhum_month
+    REAL(r_std)                       :: tau_gpp_week
+    REAL(r_std)                       :: tau_gdd
+    REAL(r_std)                       :: tau_ngd
+    REAL(r_std)                       :: tau_longterm
+    REAL(r_std), DIMENSION(nvm)                  :: lai_initmin
+    CHARACTER(len=6), DIMENSION(nvm)            :: pheno_model
+    CHARACTER(len=6), DIMENSION(nvm)            :: senescence_type
+    REAL(r_std), DIMENSION(nvm,3)                :: senescence_temp
+    REAL(r_std), DIMENSION(nvm)                  :: senescence_hum
+    REAL(r_std), DIMENSION(nvm)                  :: nosenescence_hum
+    REAL(r_std), DIMENSION(nvm)                  :: max_turnover_time
+    REAL(r_std), DIMENSION(nvm)                  :: min_leaf_age_for_senescence
+    REAL(r_std), DIMENSION(nvm)                  :: min_turnover_time
+!-
+    REAL(r_std), DIMENSION(nvm)                  :: hum_min_time
+  END TYPE pheno_type
+!-
+! parameters for the pipe model
+!-
+! crown area = pipe_tune1. stem diameter**(1.6) (Reinicke's theory)
+  REAL(r_std),PARAMETER :: pipe_tune1 = 100.0
+! height=pipe_tune2 * diameter**pipe_tune3
+  REAL(r_std),PARAMETER :: pipe_tune2 = 40.0
+  REAL(r_std),PARAMETER :: pipe_tune3 = 0.5
+! needed for stem diameter
+  REAL(r_std),PARAMETER :: pipe_tune4 = 0.3
+! Density
+  REAL(r_std),PARAMETER :: pipe_density = 2.e5
+! one more parameter
+  REAL(r_std),PARAMETER :: pipe_k1 = 8.e3
+!-
+! Maximum tree establishment rate
+  REAL(r_std),PARAMETER :: estab_max_tree = 0.12
+! Maximum grass establishment rate
+  REAL(r_std),PARAMETER :: estab_max_grass = 0.12
+! initial density of individuals
+  REAL(r_std),PARAMETER :: ind_0 = 0.02
+!-
+! Do we treat PFT expansion across a grid point after introduction?
+! default = .FALSE.
+  LOGICAL,SAVE :: treat_expansion = .FALSE.
+!-
+! herbivores?
+  LOGICAL,SAVE :: ok_herbivores = .FALSE.
+!-
+! harvesting ?
+  LOGICAL,SAVE :: harvest_agri = .TRUE.
+!-
+! For trees, minimum fraction of crown area occupied
+! (due to its branches etc.)
+! This means that only a small fraction of its crown area
+! can be invaded by other trees.
+  REAL(r_std),PARAMETER :: min_cover = 0.05
+!-
+! climatic parameters
+!-
+! minimum precip, in mm/year
+  REAL(r_std),PARAMETER :: precip_crit = 100.
+! minimum gdd for establishment of saplings
+  REAL(r_std),PARAMETER :: gdd_crit = 150.
+! critical fpc, needed for light competition and establishment
+  REAL(r_std),PARAMETER :: fpc_crit = 0.95
+!-
+! critical value for being adapted (1-1/e)
+  REAL(r_std),PARAMETER :: adapted_crit = 1. - ( 1. / euler )
+! critical value for being regenerative (1/e)
+  REAL(r_std),PARAMETER :: regenerate_crit = 1. / euler
+!-
+! fraction of GPP which is lost as growth respiration
+  REAL(r_std),PARAMETER :: frac_growthresp = 0.28
+!-
+! description of the PFT
+  CHARACTER(len=34), SAVE, DIMENSION(nvm)              :: PFT_name = &
+ & (/ 'bared ground                      ', &          !  1
+ &    'tropical  broad-leaved evergreen  ', &          !  2
+ &    'tropical  broad-leaved raingreen  ', &          !  3
+ &    'temperate needleleaf   evergreen  ', &          !  4
+ &    'temperate broad-leaved evergreen  ', &          !  5
+ &    'temperate broad-leaved summergreen', &          !  6
+ &    'boreal    needleleaf   evergreen  ', &          !  7
+ &    'boreal    broad-leaved summergreen', &          !  8
+ &    'boreal    needleleaf   summergreen', &          !  9
+ &    '          C3           grass      ', &          ! 10
+ &    '          C4           grass      ', &          ! 11
+ &    '          C3           agriculture', &          ! 12
+ &    '          C4           agriculture'  /)         ! 13
+! extinction coefficient of the Monsi&Seaki (53) relationship
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: ext_coeff
+! is pft a tree
+  LOGICAL, SAVE, DIMENSION(nvm)                        :: tree
+! leaf type
+! 1=broad leaved tree, 2=needle leaved tree, 3=grass 4=bared ground
+  INTEGER(i_std), SAVE, DIMENSION(nvm)                  :: leaf_tab = &
+ & (/      4,       1,       1,       2,       1,       1,       2,   &
+ &                  1,       2,       3,       3,       3,       3 /)
+! natural? 
+  LOGICAL, SAVE, DIMENSION(nvm)                        :: natural =    &
+ & (/  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,   &
+ &              .TRUE.,  .TRUE.,  .TRUE.,  .TRUE., .FALSE., .FALSE. /)
+! flamability: critical fraction of water holding capacity
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: flam
+! fire resistance
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: resist 
+! specific leaf area (m**2/gC)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: sla
+! sapling biomass (gC/ind)
+  REAL(r_std), SAVE, DIMENSION(nvm,nparts)              :: bm_sapl
+! migration speed (m/year)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: migrate
+! maximum stem diameter from which on crown area no longer increases (m)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: maxdia
+! crown of tree when sapling (m**2)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cn_sapl
+! critical minimum temperature (K)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tmin_crit
+! critical temperature of the coldest month (K)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tcm_crit
+! critical values for phenology
+  TYPE(pheno_type),SAVE :: pheno_crit
+! time constant for leaf age discretisation (d)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: leaf_timecst
+  ! maximum LAI, PFT-specific
+  REAL(r_std), SAVE, DIMENSION (nvm)                    :: lai_max 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C
+  REAL(r_std), SAVE, DIMENSION(nvm,nparts)              :: coeff_maint_zero
+  ! slope of maintenance respiration coefficient (1/K, 1/K^2, 1/K^3)
+  REAL(r_std), SAVE, DIMENSION(nvm,3)                   :: maint_resp_slope
+
+  ! residence time (y) of trees
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: residence_time 
+
+  ! leaf lifetime, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: leaflife_tab 
+
+  ! type of phenology
+  ! 0=bared ground 1=evergreen,  2=summergreen,  3=raingreen,  4=perennial
+  ! Pour l'instant, le phénotype de sol nu n'est pas géré aussi on traitera les sols nu comme "evergreen"
+  INTEGER(i_std), SAVE, DIMENSION(nvm)                  :: pheno_type_tab 
+
+  ! critical tmin, tabulated (C)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tmin_crit_tab 
+
+  ! critical tcm, tabulated (C)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tcm_crit_tab 
+
+  ! critical gdd, tabulated (C), constant c of aT^2+bT+c
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: gdd_crit1_tab 
+
+  ! critical gdd, tabulated (C), constant b of aT^2+bT+c
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: gdd_crit2_tab 
+
+  ! critical gdd, tabulated (C), constant a of aT^2+bT+c
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: gdd_crit3_tab 
+
+  ! critical ngd, tabulated. Threshold -5 degrees
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: ngd_crit_tab  
+
+  ! critical temperature for the ncd vs. gdd function in phenology
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: ncdgdd_temp_tab 
+
+  ! critical humidity (relative to min/max) for phenology
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: hum_frac_tab 
+
+  ! minimum duration of dormance (d) for phenology
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: lowgpp_time_tab 
+
+  ! minimum time elapsed since moisture minimum (d)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: hum_min_time_tab 
+
+  ! sapwood -> heartwood conversion time (d)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tau_sap 
+
+  ! fruit lifetime (d)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tau_fruit 
+
+  ! fraction of primary leaf and root allocation put into reserve
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: ecureuil 
+
+  ! Maximum rate of carboxylation
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: vcmax_opt 
+
+  ! Maximum rate of RUbp regeneration
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: vjmax_opt 
+
+!-
+  ! constants needed for photosynthesis temperatures
+  TYPE(t_photo_type), SAVE                              :: t_photo
+  ! lenth of death of leaves, tabulated (d)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: leaffall_tab 
+
+  ! critical leaf age, tabulated (d)
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: leafagecrit_tab 
+
+  ! which phenology model is used? (tabulated)
+  CHARACTER(len=6), SAVE, DIMENSION(nvm)               :: pheno_model_tab
+! List of avaible phenology models :
+! 'hum   ', 'moi   ', 'ncdgdd', 'ngd   ', 'humgdd', 'moigdd', 'none  '
+
+  ! type of senescence, tabulated
+  CHARACTER(len=6), SAVE, DIMENSION(nvm)               :: senescence_type_tab
+!-
+! List of avaible types of senescence :
+! 'cold  ', 'dry   ', 'mixed ', 'none  '
+
+  ! critical temperature for senescence (C), 
+  ! constant c of aT^2+bT+c , tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: senescence_temp1_tab 
+
+  ! critical temperature for senescence (C), 
+  ! constant b of aT^2+bT+c , tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: senescence_temp2_tab 
+
+  ! critical temperature for senescence (C), 
+  ! constant a of aT^2+bT+c , tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: senescence_temp3_tab 
+
+  ! critical relative moisture availability for senescence
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: senescence_hum_tab 
+
+  ! relative moisture availability above which 
+  ! there is no humidity-related senescence
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: nosenescence_hum_tab 
+
+ ! maximum turnover time for grasse
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: max_turnover_time_tab 
+
+ ! minimum turnover time for grasse
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: min_turnover_time_tab 
+
+  ! minimum leaf age to allow senescence g
+  REAL(r_std), SAVE, DIMENSION(nvm)  :: min_leaf_age_for_senescence_tab 
+
+!-
+  ! slope of maintenance respiration coefficient (1/K), 
+  ! constant c of aT^2+bT+c , tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: maint_resp_slope1_tab 
+
+  ! slope of maintenance respiration coefficient (1/K), 
+  ! constant b of aT^2+bT+c , tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: maint_resp_slope2_tab 
+
+  ! slope of maintenance respiration coefficient (1/K), 
+  ! constant a of aT^2+bT+c , tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: maint_resp_slope3_tab 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for leaves, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_leaf_tab 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for sapwood above, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_sapabove_tab 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for sapwood below, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_sapbelow_tab 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for heartwood above, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_heartabove_tab 
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for heartwood below, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_heartbelow_tab 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for roots, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_root_tab 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for fruits, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_fruit_tab 
+
+  ! maintenance respiration coefficient (g/g/day) at 0 deg C, 
+  ! for carbohydrate reserve, tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: cm_zero_carbres_tab 
+
+!-
+  ! minimum photosynthesis temperature, 
+  ! constant a of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_min_a_tab 
+
+  ! minimum photosynthesis temperature, 
+  ! constant b of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_min_b_tab 
+
+  ! minimum photosynthesis temperature, 
+  ! constant c of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_min_c_tab 
+
+!-
+  ! optimum photosynthesis temperature, 
+  ! constant a of ax^2+bx+c (deg C), tabulated
+
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_opt_a_tab 
+
+  ! optimum photosynthesis temperature, 
+  ! constant b of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_opt_b_tab 
+
+  ! optimum photosynthesis temperature, 
+  ! constant c of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_opt_c_tab 
+
+!-
+  ! maximum photosynthesis temperature, 
+  ! constant a of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_max_a_tab 
+
+  ! maximum photosynthesis temperature, 
+  ! constant b of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_max_b_tab 
+
+  ! maximum photosynthesis temperature, 
+  ! constant c of ax^2+bx+c (deg C), tabulated
+  REAL(r_std), SAVE, DIMENSION(nvm)                     :: tphoto_max_c_tab 
+
+  ! NEW - allocation above/below = f(age) - 30/01/04 NV/JO/PF
+  REAL(r_std), SAVE, DIMENSION(nvm)                  :: alloc_min 
+  REAL(r_std), SAVE, DIMENSION(nvm)                  :: alloc_max 
+  REAL(r_std), SAVE, DIMENSION(nvm)                  :: demi_alloc 
+
+  ! Coeff of biomass export for the year
+  REAL(r_std), SAVE, DIMENSION(nvm)                  :: coeff_lcchange_1 
+
+  ! Coeff of biomass export for the decade
+  REAL(r_std), SAVE, DIMENSION(nvm)                  :: coeff_lcchange_10 
+
+  ! Coeff of biomass export for the century
+  REAL(r_std), SAVE, DIMENSION(nvm)                  :: coeff_lcchange_100 
+
+CONTAINS
+  SUBROUTINE stomate_constants_init ()
+  ! flamability: critical fraction of water holding capacity
+  flam(2:nvm) =       &
+ & (/      .15,     .25,     .25,     .25,     .25,     .25,   &
+           .25,     .25,     .25,     .25,     .35,     .35 /)
+!!$  flam(2:nvm) =       &
+!!$ & (/        .25,     .25,     .25,     .25,     .25,     .25,   &
+!!$                   .25,     .25,     .30,     .30,     .35,     .35 /)
+!  flam =       &
+! & (/        .15,     .15,     .15,     .15,     .15,     .15,   &
+! &                 .15,     .15,     .15,     .15,     .15,     .15 /)
+  ! fire resistance
+  resist(2:nvm) =     &
+ & (/     .95,     .90,     .12,     .50,     .12,     .12,   &
+ &        .12,     .12,      .0,      .0,      .0,      .0 /)
+!!$  resist(2:nvm) =     &
+!!$ & (/        .12,     .50,     .12,     .50,     .12,     .12,   &
+!!$ &                 .12,     .12,      .0,      .0,      .0,      .0 /)
+! maximum LAI, PFT-specific
+  lai_max(:) =   &
+ & (/     undef, &
+ &          7.,     7.,      5.,      5.,      5.,     4.5, &
+ &        4.5,    3.0,     2.5,     2.5,     5.,     5.  /)
+! residence time (y) of trees
+  residence_time(2:nvm) =    &
+ & (/    30.0,    30.0,    40.0,    40.0,    40.0,    80.0, &
+ &       80.0,    80.0,     0.0,     0.0,     0.0,     0.0 /)
+! leaf lifetime, tabulated
+!SZ modif to LPJ values
+  leaflife_tab(2:nvm) =      &
+ & (/        .5,      2.,     .33,      1.,     2.,      .33,   &
+ &           2.,      2.,      2.,      2.,     2.,        2. /)
+!!$  leaflife_tab(2:nvm) =      &
+!!$ & (/      .5,      1.,      .5,      .5,      1.,      .5, &
+!!$ &        1.,       1.,      1.,      1.,      1.,     1.  /)
+! type of phenology
+  ! 0=bared ground 1=evergreen,  2=summergreen,  3=raingreen,  4=perennial
+  ! Pour l'instant, le phénotype de sol nu n'est pas géré aussi on traitera les sols nu comme "evergreen"
+  pheno_type_tab(2:nvm) =    &
+ & (/      1,        3,       1,       1,       2,       1, &
+ &         2,        2,       4,       4,       2,       3 /)
+! critical tmin, tabulated (C)
+  tmin_crit_tab(2:nvm) =    &
+ & (/     0.0,     0.0,   -45.0,   -10.0,   -45.0,   -60.0, &
+ &      -60.0,   undef,   undef,   undef,   undef,   undef /)
+! critical tcm, tabulated (C)
+  tcm_crit_tab(2:nvm) =     &
+ & (/   undef,   undef,     5.0,    15.5,    15.5,    -2.0, &
+ &        5.0,    -2.0,   undef,   undef,   undef,   undef /)
+! critical gdd, tabulated (C), constant c of aT^2+bT+c
+  gdd_crit1_tab(2:nvm) =    &
+ & (/   undef,   undef,   undef,   undef,   undef,   undef, &
+ &      undef,   undef,     270.,   400.,    125.,    400. /)
+!!$ gdd_crit1_tab(2:nvm) = &
+!!$ & (/   undef,   undef,   undef,   undef,   undef,   undef, &
+!!$ &      undef,   undef, 184.375,    400.,    125.,    400. /)
+! critical gdd, tabulated (C), constant b of aT^2+bT+c
+  gdd_crit2_tab(2:nvm) =    &
+ & (/   undef,   undef,   undef,   undef,   undef,   undef, &
+ &      undef,   undef,    6.25,      0.,      0.,       0. /)
+! critical gdd, tabulated (C), constant a of aT^2+bT+c
+  gdd_crit3_tab(2:nvm) =    &
+ & (/   undef,   undef,   undef,   undef,   undef,   undef, &
+ &      undef,   undef, 0.03125,      0.,      0.,       0. /)
+! critical ngd, tabulated. Threshold -5 degrees
+  ngd_crit_tab(2:nvm)  =    &
+ & (/   undef,   undef,   undef,   undef,   undef,   undef, &
+ &      undef,     17.,   undef,   undef,   undef,   undef /)
+! critical temperature for the ncd vs. gdd function in phenology
+  ncdgdd_temp_tab(2:nvm) =  &
+ & (/   undef,   undef,   undef,   undef,      5.,   undef, &
+ &         0.,   undef,   undef,   undef,   undef,   undef /)
+! critical humidity (relative to min/max) for phenology
+  hum_frac_tab(2:nvm) =     &
+ & (/      undef,      .5,   undef,   undef,   undef,   undef,         &
+ &         undef,   undef,      .5,      .5,      .5,      .5         /)
+! minimum duration of dormance (d) for phenology
+  lowgpp_time_tab(2:nvm) =  &
+ & (/      undef,     30.,   undef,   undef,     30.,   undef,   &
+ &           30.,     30.,     30.,     30.,     30.,     30. /)
+! minimum time elapsed since moisture minimum (d)
+  hum_min_time_tab(2:nvm) =   &
+ & (/      undef,     50.,   undef,   undef,   undef,   undef,           &
+ &         undef,   undef,     35.,     35.,     75.,     75.           /)
+! sapwood -> heartwood conversion time (d)
+  tau_sap(2:nvm) =       &
+ & (/       730.,    730.,    730.,    730.,    730.,    730.,      &
+ &          730.,    730.,   undef,   undef,   undef,   undef      /)
+! fruit lifetime (d)
+  tau_fruit(2:nvm) =     &
+ & (/        90.,     90.,     90.,     90.,     90.,     90.,      &
+ &           90.,     90.,   undef,   undef,   undef,   undef      /)
+! fraction of primary leaf and root allocation put into reserve
+  ecureuil(2:nvm) =      &
+ & (/         .0,      1.,      .0,      .0,      1.,      .0,      &
+ &            1.,      1.,      1.,      1.,      1.,      1.      /)
+! Maximum rate of carboxylation
+!Shilong
+  vcmax_opt(:) =     &
+ & (/      undef, &
+ &         65.,     65.,     35.,     45.,     55.,     35.,      &
+ &         45.,     35.,     70.,     70.,    70.,    70.      /)
+  CALL getin_p("vcmax_opt", vcmax_opt)
+! 1.9.3
+!!$  vcmax_opt(2:nvm) =     &
+!!$ & (/     65.,     65.,     35.,     40.,     55.,     35.,   &
+!!$ &        45.,     35.,     70.,     70.,     70.,     70. /
+! OLD HEAD before 1.9.3
+!!$  vcmax_opt(2:nvm) =     &
+!!$ & (/        65.,     65.,     35.,     40.,     55.,     35.,      &
+!!$ &                 45.,     35.,     80.,     80.,    100.,    100.      /)
+!modif jerome carbofor
+! vcmax_opt = &
+! & (/        65.,     65.,     50.,     40.,     75.,     35.,   &
+! &           45.,     35.,     80.,     80.,    100.,    100. /)
+  !DATA vcmax_opt_tab          /      0.,     65.,     65.,    37.5,     45.,     60.,    37.5,   &
+  !                                  50.,     40.,    100.,    100.,    100.,    100. / 
+!-
+! Maximum rate of RUbp regeneration
+  vjmax_opt(2:nvm) =     &
+ & (/       130.,    130.,     70.,     80.,    110.,     70.,      &
+ &           90.,     70.,    160.,    160.,    200.,    200.      /)
+!-
+  !DATA vjmax_opt_tab          /      0.,    130.,    130.,     75.,     90.,    120.,     75.,   &
+  !                                 100.,     80.,    200.,    200.,    200.,    200. /
+!-
+! length of death of leaves, tabulated (d)
+  leaffall_tab(2:nvm) =    &
+ & (/      undef,     10.,   undef,   undef,     10.,   undef,        &
+ &           10.,     10.,     10.,     10.,     10.,     10.        /)
+! critical leaf age, tabulated (d)
+! Shilong modification
+  leafagecrit_tab(2:nvm) =     &
+ & (/       730.,    180.,    910.,    730.,    180.,    910.,            &
+ &          180.,    180.,    120.,    120.,    90.,    90.            /)
+! OLD HEAD
+!!$  DATA leafagecrit_tab        /    730.,    180.,    910.,    730.,    180.,    910.,   &
+!!$                                   180.,    180.,    120.,    120.,    120.,    120. /
+!NEW SHILONG
+! & (/     730.,    180.,    910.,    730.,    180.,    910.,            &
+! &        180.,    180.,    120.,    120.,     70.,     70.            /)
+!-
+  ! which phenology model is used? (tabulated)
+  pheno_model_tab(1:nvm) =   &
+ & (/  'none  ',   'none  ',   'moi   ',   'none  ',   'none  ',   &
+ &     'ncdgdd',   'none  ',   'ncdgdd',   'ngd   ',   'moigdd',   &
+ &     'moigdd',   'moigdd',   'moigdd'           /) 
+! List of avaible phenology models :
+! 'hum   ', 'moi   ', 'ncdgdd', 'ngd   ', 'humgdd', 'moigdd', 'none  '
+!-
+  ! type of senescence, tabulated
+  senescence_type_tab(1:nvm) =   &
+ & (/  'none  ',  'none  ',   'dry   ',  'none  ',  'none  ',   &
+ &     'cold  ',  'none  ',   'cold  ',  'cold  ',  'mixed ',   &
+ &     'mixed ',  'mixed ',   'mixed '            /)
+!-
+! List of avaible types of senescence :
+! 'cold  ', 'dry   ', 'mixed ', 'none  '
+!-
+! critical temperature for senescence (C),
+! constant c of aT^2+bT+c , tabulated
+  senescence_temp1_tab(2:nvm) =   &
+ & (/      undef,   undef,   undef,   undef,     12.,   undef,               &
+ &            7.,      2.,  -1.375,      5.,      5.,     10.               /)
+! critical temperature for senescence (C),
+! constant b of aT^2+bT+c , tabulated
+  senescence_temp2_tab(2:nvm) =   &
+ & (/      undef,   undef,   undef,   undef,      0.,   undef,               &
+ &            0.,      0.,      .1,      0.,      0.,      0.               /)
+! critical temperature for senescence (C),
+! constant a of aT^2+bT+c , tabulated
+  senescence_temp3_tab(2:nvm) =   &
+ & (/      undef,   undef,   undef,   undef,      0.,   undef,               &
+ &            0.,      0.,  .00375,      0.,      0.,      0.               /)
+! critical relative moisture availability for senescence
+!SZ 080806, reparameterisation of TrBR: reduce criticial moisture from .6 to .3 
+! to mimic a leaf dropping at -1.49 MPa, buffered to account for sechiba
+  senescence_hum_tab(2:nvm) =  &
+ & (/      undef,      .3,   undef,   undef,   undef,   undef,            &
+ &         undef,   undef,      .2,      .2,      .3,      .2            /)
+! 1.9.3
+!!$  senescence_hum_tab(2:nvm) =  &
+!!$ & (/      undef,      .6,   undef,   undef,   undef,   undef,            &
+!!$ &         undef,   undef,      .2,      .2,      .3,      .2            /)
+! relative moisture availability above which
+! there is no humidity-related senescence
+!SZ 080806, reparameterisation of TrBR: reduce nosenencemoisture to avoid leaf dropping
+! when phenology routine would give new flushing of leaves: 1.0 to 0.8
+  nosenescence_hum_tab(2:nvm) =  &
+ & (/      undef,      .8,   undef,   undef,   undef,   undef,              &
+ &               undef,   undef,      .3,      .3,      .3,      .3              /)
+! 1.9.3
+!!$  nosenescence_hum_tab(2:nvm) =  &
+!!$ & (/      undef,      1.,   undef,   undef,   undef,   undef,              &
+!!$ &               undef,   undef,      .3,      .3,      .3,      .3              /)
+
+! maximum turnover time for grasse
+  max_turnover_time_tab(2:nvm) =   &
+ & (/      undef,   undef,    undef,   undef,   undef,   undef,                &
+ &         undef,   undef,      80.,     80.,     80.,     80.                /)
+! minimum turnover time for grasse
+  min_turnover_time_tab(2:nvm) =   &
+ & (/      undef,    undef,    undef,    undef,   undef,   undef,              &
+ &         undef,   undef,      10.,      10.,      10.,      10.             /)
+! minimum leaf age to allow senescence g
+  min_leaf_age_for_senescence_tab(:) =   &
+ & (/    undef, &
+ &       undef,    90.,   undef,   undef,    90.,    undef,          &
+ &         60.,    60.,     30.,     30.,    30.,      30.          /)
+!-
+! slope of maintenance respiration coefficient (1/K),
+! constant c of aT^2+bT+c , tabulated
+!SZ - 1.9.3
+  maint_resp_slope1_tab(2:nvm) =   &
+ & (/        .12,     .12,     .16,     .16,     .16,     .16,                &
+ &           .16,     .16,     .16,     .12,     .16,     .12                /)
+!OLD MERGE
+!!$  maint_resp_slope1_tab(2:nvm) =   &
+!!$ & (/        .16,     .16,     .16,     .16,     .16,     .16,                &
+!!$ &                 .16,     .16,     .16,     .12,     .16,     .16                /)
+!Shilong
+!!$  maint_resp_slope1_tab(2:nvm) =   &
+!!$ & (/      .12,     .12,     .16,     .16,     .16,     .16,                &
+!!$ &         .16,     .16,     .16,     .16,     .16,     .16                /)
+!-
+! slope of maintenance respiration coefficient (1/K),
+! constant b of aT^2+bT+c , tabulated
+  maint_resp_slope2_tab(2:nvm) =   &
+ & (/         .0,      .0,      .0,      .0,      .0,      .0,                &
+ &            .0,      .0, -.00133,      .0, -.00133,      .0                /)
+  ! DATA maint_resp_slope2_tab  /      .0,      .0,      .0,      .0,      .0,      .0,      .0,   &
+  !                                    .0,      .0,      .0,      .0,      .0,      .0 /
+! slope of maintenance respiration coefficient (1/K),
+! constant a of aT^2+bT+c , tabulated
+  maint_resp_slope3_tab(2:nvm) =   &
+ & (/         .0,      .0,      .0,      .0,      .0,      .0,                &
+ &            .0,      .0,      .0,      .0,      .0,      .0                /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for leaves, tabulated
+  cm_zero_leaf_tab(2:nvm) =    &
+ & (/    2.35E-3, 2.62E-3, 1.01E-3, 2.35E-3, 2.62E-3, 1.01E-3,            &
+ &       2.62E-3, 2.05E-3, 2.62E-3, 2.62E-3, 2.62E-3, 2.62E-3            /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for sapwood above, tabulated
+  cm_zero_sapabove_tab(2:nvm) =    &
+ & (/    1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4,                &
+ &       1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4                /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for sapwood below, tabulated
+  cm_zero_sapbelow_tab(2:nvm) =    &
+ & (/    1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4,                &
+ &       1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4                /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for heartwood above, tabulated
+  cm_zero_heartabove_tab(2:nvm) =  &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,                &
+ &            0.,      0.,      0.,      0.,      0.,      0.                /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for heartwood below, tabulated
+  cm_zero_heartbelow_tab(2:nvm) =  &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,                &
+ &            0.,      0.,      0.,      0.,      0.,      0.                /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for roots, tabulated
+  cm_zero_root_tab(2:nvm) =    &
+ & (/    1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3,            &
+ &       1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3, 1.67E-3            /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for fruits, tabulated
+  cm_zero_fruit_tab(2:nvm) =   &
+ & (/    1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4,            &
+ &       1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4            /)
+!-
+! maintenance respiration coefficient (g/g/day) at 0 deg C,
+! for carbohydrate reserve, tabulated
+  cm_zero_carbres_tab(2:nvm) =    &
+ & (/    1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4,               &
+ &       1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4, 1.19E-4               /)
+!-
+! minimum photosynthesis temperature,
+! constant a of ax^2+bx+c (deg C), tabulated
+  tphoto_min_a_tab(2:nvm) =   &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,           &
+ &            0.,      0.,  0.0025,      0.,      0.,      0.           /)
+!-
+! minimum photosynthesis temperature,
+! constant b of ax^2+bx+c (deg C), tabulated
+  tphoto_min_b_tab(2:nvm) =   &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,           &
+ &            0.,      0.,     0.1,      0.,      0.,      0.           /)
+!-
+! minimum photosynthesis temperature,
+! constant c of ax^2+bx+c (deg C), tabulated
+  tphoto_min_c_tab(2:nvm) =   &
+ & (/         2.,      2.,     -4.,     -3.,     -2.,     -4.,           &
+ &           -4.,     -4.,   -3.25,     13.,     -5.,     13.           /)
+!-
+! optimum photosynthesis temperature,
+! constant a of ax^2+bx+c (deg C), tabulated
+  tphoto_opt_a_tab(2:nvm) =   &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,           &
+              0.,      0.,  0.0025,      0.,      0.,      0.           /)
+! optimum photosynthesis temperature,
+! constant b of ax^2+bx+c (deg C), tabulated
+  tphoto_opt_b_tab(2:nvm) =   &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,           &
+ &            0.,      0.,    0.25,      0.,      0.,      0.           /)
+!-
+! optimum photosynthesis temperature,
+! constant c of ax^2+bx+c (deg C), tabulated
+  tphoto_opt_c_tab(2:nvm) =    &
+ & (/        37.,     37.,     25.,     32.,     26.,     25.,           &
+ &           25.,     25.,   27.25,     36.,     30.,     36.           /)
+!-
+! maximum photosynthesis temperature,
+! constant a of ax^2+bx+c (deg C), tabulated
+  tphoto_max_a_tab(2:nvm) =    &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,             &
+ &            0.,      0., 0.00375,      0.,      0.,      0.            /)
+!-
+! maximum photosynthesis temperature,
+! constant b of ax^2+bx+c (deg C), tabulated
+  tphoto_max_b_tab(2:nvm) =    &
+ & (/         0.,      0.,      0.,      0.,      0.,      0.,            &
+ &            0.,      0.,    0.35,      0.,      0.,      0.            /)
+!-
+! maximum photosynthesis temperature,
+! constant c of ax^2+bx+c (deg C), tabulated
+  tphoto_max_c_tab(2:nvm) =    &
+ & (/        55.,     55.,     38.,     48.,     38.,     38.,            &
+ &           38.,     38.,  41.125,     55.,     45.,     55.            /)
+!-
+  ! NEW - allocation above/below = f(age) - 30/01/04 NV/JO/PF
+  alloc_min(2:nvm) =               &
+ & (/          0.2,       0.2,       0.2,       0.2,     0.2,     0.2,   &
+ &             0.2,       0.2,     undef,     undef,   undef,   undef   /)
+  alloc_max(2:nvm) =               &
+ & (/          0.8,       0.8,       0.8,       0.8,     0.8,     0.8,   &
+ &             0.8,       0.8,     undef,     undef,   undef,   undef   /)
+  demi_alloc(2:nvm) =              &
+ & (/           5.,        5.,       5.,        5.,       5.,      5.,   &
+ &              5.,        5.,    undef,     undef,    undef,   undef   /)
+
+  ! Coeff of biomass export for the year
+  coeff_lcchange_1(2:nvm) = &
+ & (/        0.597,     0.597,    0.597,     0.597,    0.597,   0.597,   &
+ &           0.597,     0.597,    0.597,     0.597,    0.597,   0.597   /)
+  ! Coeff of biomass export for the decade
+  coeff_lcchange_10(2:nvm) = &
+ & (/        0.403,     0.403,    0.299,     0.299,    0.299,   0.299,   &
+ &           0.299,     0.299,    0.299,     0.403,    0.299,   0.403   /)
+  ! Coeff of biomass export for the century
+  coeff_lcchange_100(2:nvm) = &
+ & (/           0.,        0.,    0.104,     0.104,    0.104,   0.104,   &
+ &           0.104,     0.104,    0.104,        0.,    0.104,      0.   /)
+
+  END SUBROUTINE stomate_constants_init
+
+!---------------------------
+END MODULE stomate_constants
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_data.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_data.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_data.f90	(revision 55)
@@ -0,0 +1,651 @@
+! defines PFT parameters
+! the geographical coordinates might be used for defining some additional parameters
+! (e.g. frequency of anthropogenic fires, irrigation of agricultural surfaces, etc.)
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_data.f90,v 1.12 2009/06/24 10:53:17 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_data
+
+  ! modules used:
+
+  USE constantes_veg
+  USE constantes_co2
+  USE stomate_constants
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC data
+
+CONTAINS
+
+  SUBROUTINE data (npts, lalo)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                               :: npts
+    ! Geographical coordinates (latitude,longitude)
+    REAL(r_std),DIMENSION (npts,2), INTENT (in)        :: lalo
+
+    ! 0.2 local variables
+
+    ! Index
+    INTEGER(i_std)                                    :: j
+    ! alpha's : ?
+    REAL(r_std)                                        :: alpha
+    ! stem diameter
+    REAL(r_std)                                        :: dia
+    ! Sapling CSA
+    REAL(r_std)                                        :: csa_sap
+    ! mass ratio (heartwood+sapwood)/sapwood
+    REAL(r_std), PARAMETER                             :: x = 3.
+
+    ! =========================================================================
+
+    IF ( bavard .GE. 1 ) WRITE(numout,*) 'data: PFT characteristics'
+
+    pheno_crit% min_leaf_age_for_senescence(1) = min_leaf_age_for_senescence_tab(1)
+
+    DO j = 2,nvm
+
+       IF ( bavard .GE. 1 ) WRITE(numout,'(a,i3,a,a)') '    > PFT#',j,': ', PFT_name(j)
+
+       !
+       ! 1 tree?
+       !
+
+       IF ( leaf_tab(j) .LE. 2 ) THEN
+          tree(j) = .TRUE.
+       ELSE
+          tree(j) = .FALSE.
+       ENDIF
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       tree: ', tree(j)
+
+       !
+       ! 2 flamability
+       !
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       litter flamability:', flam(j)
+
+       !
+       ! 3 fire resistance
+       !
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       fire resistance:', resist(j)
+
+       !
+       ! 4 specific leaf area per mass carbon = 2 * sla / dry mass
+       !
+
+       ! SZ: Reich et al, 1992 find no statistically significant differences between broadleaved and coniferous
+       ! forests, specifically, the assumption that grasses grow needles is not justified. Replacing the function
+       ! with the one based on Reich et al. 1997. Given that sla=100cm2/gDW at 9 months, sla is:
+       ! sla=exp(5.615-0.46*ln(leaflon in months))
+
+       ! includes conversion from 
+       !!       sla(j) = 2. * 1e-4 * EXP(5.615 - 0.46 * log(12./leaflife_tab(j)))
+
+       IF ( leaf_tab(j) .EQ. 2 ) THEN
+
+          ! needle leaved tree
+          sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
+
+       ELSE
+
+          ! broad leaved tree or grass (Reich et al 1992)
+          sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
+
+       ENDIF
+
+!!$      IF ( leaf_tab(j) .EQ. 1 ) THEN
+!!$
+!!$        ! broad leaved tree
+!!$
+!!$        sla(j) = 2. * ( 10. ** ( 2.41 - 0.38 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
+!!$
+!!$      ELSE
+!!$
+!!$        ! needle leaved or grass (Reich et al 1992)
+!!$
+!!$        sla(j) = 2. * ( 10. ** ( 2.29 - 0.4 * LOG10(12./leaflife_tab(j)) ) ) *1e-4
+!!$
+!!$      ENDIF
+!!$
+!!$      IF ( ( leaf_tab(j) .EQ. 2 ) .AND. ( pheno_type_tab(j) .EQ. 2 ) ) THEN
+!!$
+!!$        ! summergreen needle leaf
+!!$
+!!$        sla(j) = 1.25 * sla(j)
+!!$
+!!$      ENDIF
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       specific leaf area (m**2/gC):', sla(j), 12./leaflife_tab(j)
+
+       !
+       ! 5 sapling characteristics
+       !
+
+       IF ( tree(j) ) THEN
+
+          ! 5.1 trees
+
+          alpha = alpha_tree
+
+          bm_sapl(j,ileaf) = &
+               ( (4.*pipe_tune1 * ( x*4.*sla(j)/(pi*pipe_k1))**.8 ) / sla(j) ) ** 5.
+
+          IF ( pheno_type_tab(j) .NE. 1 ) THEN
+             ! not evergreen
+             bm_sapl(j,icarbres) = 5. * bm_sapl(j,ileaf)
+          ELSE
+             bm_sapl(j,icarbres) = zero
+          ENDIF
+
+          csa_sap = bm_sapl(j,ileaf) / ( pipe_k1 / sla(j) )
+
+          dia = ( x * csa_sap * 4. / pi ) ** 0.5
+
+          bm_sapl(j,isapabove) = &
+               .5 * pipe_density * csa_sap * pipe_tune2 * dia ** pipe_tune3
+          bm_sapl(j,isapbelow) = bm_sapl(j,isapabove)
+
+          bm_sapl(j,iheartabove) = 2. * bm_sapl(j,isapabove)
+          bm_sapl(j,iheartbelow) = 2. * bm_sapl(j,isapbelow)
+
+       ELSE
+
+          ! 5.2 grasses
+
+          alpha = alpha_grass
+
+          IF ( natural(j) ) THEN
+             bm_sapl(j,ileaf) = 0.1 / sla(j)
+          ELSE
+             bm_sapl(j,ileaf) = un / sla(j)
+          ENDIF
+
+          bm_sapl(j,icarbres) = 5.*bm_sapl(j,ileaf)
+
+          bm_sapl(j,isapabove) = zero
+          bm_sapl(j,isapbelow) = zero
+
+          bm_sapl(j,iheartabove) = zero
+          bm_sapl(j,iheartbelow) = zero
+
+       ENDIF
+
+       bm_sapl(j,iroot) = 0.1 * (1./alpha) * bm_sapl(j,ileaf)
+
+       bm_sapl(j,ifruit) = 0.3 * bm_sapl(j,ileaf)
+
+       IF ( bavard .GE. 1 ) THEN
+          WRITE(numout,*) '       sapling biomass (gC):'
+          WRITE(numout,*) '         leaves:',bm_sapl(j,ileaf)
+          WRITE(numout,*) '         sap above ground:',bm_sapl(j,isapabove)
+          WRITE(numout,*) '         sap below ground:',bm_sapl(j,isapbelow)
+          WRITE(numout,*) '         heartwood above ground:',bm_sapl(j,iheartabove)
+          WRITE(numout,*) '         heartwood below ground:',bm_sapl(j,iheartbelow)
+          WRITE(numout,*) '         roots:',bm_sapl(j,iroot)
+          WRITE(numout,*) '         fruits:',bm_sapl(j,ifruit)
+          WRITE(numout,*) '         carbohydrate reserve:',bm_sapl(j,icarbres)
+       ENDIF
+
+       !
+       ! 6 migration speed (m/year)
+       !
+
+       IF ( tree(j) ) THEN
+
+          migrate(j) = 10.*1.E3
+
+       ELSE
+
+          ! can be any value as grasses are, per definitionem, everywhere (big leaf).
+          migrate(j) = 10.*1.E3
+
+       ENDIF
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       migration speed (m/year):', migrate(j)
+
+       !
+       ! 7 critical stem diameter: beyond this diameter, the crown area no longer
+       !     increases
+       !
+
+       IF ( tree(j) ) THEN
+
+          maxdia(j) = ( ( pipe_tune4 / ((pipe_tune2*pipe_tune3)/(100.**pipe_tune3)) ) &
+               ** ( un / ( pipe_tune3 - un ) ) ) * 0.01
+          cn_sapl(j) =0.5 !crown of individual tree, first year
+
+       ELSE
+
+          maxdia(j) = undef
+          cn_sapl(j)=1
+
+       ENDIF
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       critical stem diameter (m):', maxdia(j)
+
+       !
+       ! 8 Coldest tolerable temperature
+       !
+
+       IF ( ABS( tmin_crit_tab(j) - undef ) .GT. min_stomate ) THEN
+          tmin_crit(j) = tmin_crit_tab(j) + ZeroCelsius
+       ELSE
+          tmin_crit(j) = undef
+       ENDIF
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       coldest tolerable temperature (K):', tmin_crit(j)
+
+       !
+       ! 9 Maximum temperature of the coldest month: need to be below this temperature
+       !      for a certain time to regrow leaves next spring
+       !
+
+       IF ( ABS ( tcm_crit_tab(j) - undef ) .GT. min_stomate ) THEN
+          tcm_crit(j) = tcm_crit_tab(j) + ZeroCelsius
+       ELSE
+          tcm_crit(j) = undef
+       ENDIF
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       vernalization temperature (K):', tcm_crit(j)
+
+       !
+       ! 10 critical values for phenology
+       !
+
+       ! 10.1 model used
+
+       pheno_crit%pheno_model(j) = pheno_model_tab(j)
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       phenology model used: ',pheno_crit%pheno_model(j)
+
+       ! 10.2 growing degree days. What kind of gdd is meant (i.e. threshold 0 or -5 deg C
+       !        or whatever), depends on how this is used in stomate_phenology.
+
+       pheno_crit%gdd(j,1) = gdd_crit1_tab(j)
+       pheno_crit%gdd(j,2) = gdd_crit2_tab(j)
+       pheno_crit%gdd(j,3) = gdd_crit3_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( ALL(pheno_crit%gdd(j,:) .NE. undef) ) ) THEN
+          WRITE(numout,*) '         critical GDD is a function of long term T (C):'
+          WRITE(numout,*) '          ',pheno_crit%gdd(j,1), &
+               ' + T *',pheno_crit%gdd(j,2), &
+               ' + T^2 *',pheno_crit%gdd(j,3)
+       ENDIF
+
+       ! consistency check
+
+       IF ( ( ( pheno_crit%pheno_model(j) .EQ. 'moigdd' ) .OR. &
+            ( pheno_crit%pheno_model(j) .EQ. 'humgdd' )       ) .AND. &
+            ( ANY(pheno_crit%gdd(j,:) .EQ. undef) )                      ) THEN
+          STOP 'problem with phenology parameters, critical GDD.'
+       ENDIF
+
+       ! 10.3 number of growing days
+
+       pheno_crit%ngd(j) = ngd_crit_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%ngd(j) .NE. undef ) ) &
+            WRITE(numout,*) '         critical NGD:', pheno_crit%ngd(j)
+
+       ! 10.4 critical temperature for ncd vs. gdd function in phenology
+
+       pheno_crit%ncdgdd_temp(j) = ncdgdd_temp_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%ncdgdd_temp(j) .NE. undef ) ) &
+            WRITE(numout,*) '         critical temperature for NCD vs. GDD (C):', &
+            pheno_crit%ncdgdd_temp(j)
+
+       ! 10.5 humidity fractions
+
+       pheno_crit%hum_frac(j) = hum_frac_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%hum_frac(j) .NE. undef ) ) &
+            WRITE(numout,*) '         critical humidity fraction:', pheno_crit%hum_frac(j)
+
+       ! 10.6 minimum time during which there was no photosynthesis
+
+       pheno_crit%lowgpp_time(j) = lowgpp_time_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%lowgpp_time(j) .NE. undef ) ) &
+            WRITE(numout,*) '         minimum dormance duration (d):', pheno_crit%lowgpp_time(j)
+
+       ! 10.7 minimum time elapsed since moisture minimum (d)
+
+       pheno_crit%hum_min_time(j) = hum_min_time_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%hum_min_time(j) .NE. undef ) ) &
+            WRITE(numout,*) '         time to wait after moisture min (d):', pheno_crit%hum_min_time(j)
+
+       !
+       ! 11 critical values for senescence
+       !
+
+       ! 11.1 type of senescence
+
+       pheno_crit%senescence_type(j) = senescence_type_tab(j)
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       type of senescence: ',pheno_crit%senescence_type(j)
+
+       ! 11.2 critical temperature for senescence
+
+       pheno_crit%senescence_temp(j,1) = senescence_temp1_tab(j)
+       pheno_crit%senescence_temp(j,2) = senescence_temp2_tab(j)
+       pheno_crit%senescence_temp(j,3) = senescence_temp3_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( ALL(pheno_crit%senescence_temp(j,:) .NE. undef) ) ) THEN
+          WRITE(numout,*) '         critical temperature for senescence (C) is'
+          WRITE(numout,*) '          a function of long term T (C):'
+          WRITE(numout,*) '          ',pheno_crit%senescence_temp(j,1), &
+               ' + T *',pheno_crit%senescence_temp(j,2), &
+               ' + T^2 *',pheno_crit%senescence_temp(j,3)
+       ENDIF
+
+       ! consistency check
+
+       IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'cold' ) .OR. &
+            ( pheno_crit%senescence_type(j) .EQ. 'mixed' )      ) .AND. &
+            ( ANY(pheno_crit%senescence_temp(j,:) .EQ. undef ) )           ) THEN
+          STOP 'problem with senescence parameters, temperature.'
+       ENDIF
+
+       ! 11.3 critical relative moisture availability for senescence
+
+       pheno_crit%senescence_hum(j) = senescence_hum_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%senescence_hum(j) .NE. undef ) ) &
+            WRITE(numout,*) '         max. critical relative moisture availability for senescence:', &
+            pheno_crit%senescence_hum(j)
+
+       ! consistency check
+
+       IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'dry' ) .OR. &
+            ( pheno_crit%senescence_type(j) .EQ. 'mixed' )     ) .AND. &
+            ( pheno_crit%senescence_hum(j) .EQ. undef )                   ) THEN
+          STOP 'problem with senescence parameters, humidity.'
+       ENDIF
+
+       ! 14.3 relative moisture availability above which there is no moisture-related
+       !      senescence
+
+       pheno_crit%nosenescence_hum(j) = nosenescence_hum_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%nosenescence_hum(j) .NE. undef ) ) &
+            WRITE(numout,*) '         relative moisture availability above which there is'
+       WRITE(numout,*) '             no moisture-related senescence:', &
+            pheno_crit%nosenescence_hum(j)
+
+       pheno_crit% max_turnover_time(j) = max_turnover_time_tab(j)
+       pheno_crit% min_turnover_time(j) = min_turnover_time_tab(j)
+       pheno_crit% min_leaf_age_for_senescence(j) = min_leaf_age_for_senescence_tab(j)
+
+       ! consistency check
+
+       IF ( ( ( pheno_crit%senescence_type(j) .EQ. 'dry' ) .OR. &
+            ( pheno_crit%senescence_type(j) .EQ. 'mixed' )     ) .AND. &
+            ( pheno_crit%nosenescence_hum(j) .EQ. undef )                   ) THEN
+          STOP 'problem with senescence parameters, humidity.'
+       ENDIF
+
+       !
+       ! 12 sapwood -> heartwood conversion time
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       sapwood -> heartwood conversion time (d):', tau_sap(j)
+
+       !
+       ! 13 fruit lifetime
+       !
+
+       IF ( bavard .GE. 1 ) WRITE(numout,*) '       fruit lifetime (d):', tau_fruit(j)
+
+       !
+       ! 14 length of leaf death
+       !      For evergreen trees, this variable determines the lifetime of the leaves.
+       !      Note that it is different from the value given in leaflife_tab.
+       !
+
+       pheno_crit%leaffall(j) = leaffall_tab(j)
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       length of leaf death (d):', pheno_crit%leaffall(j)
+
+       !
+       ! 15 maximum lifetime of leaves
+       !
+
+       pheno_crit%leafagecrit(j) = leafagecrit_tab(j)
+
+       IF ( ( bavard .GE. 1 ) .AND. ( pheno_crit%leafagecrit(j) .NE. undef ) ) &
+            WRITE(numout,*) '       critical leaf age (d):', pheno_crit%leafagecrit(j)
+
+       !
+       ! 16 time constant for leaf age discretisation (d)
+       !
+
+       leaf_timecst(j) = pheno_crit%leafagecrit(j) / REAL( nleafages,r_std )
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       time constant for leaf age discretisation (d):', &
+            leaf_timecst(j)
+
+       !
+       ! 17 minimum lai, initial
+       !
+
+       IF ( tree(j) ) THEN
+          pheno_crit%lai_initmin(j) = 0.3
+       ELSE
+          pheno_crit%lai_initmin(j) = 0.1
+       ENDIF
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       initial LAI:', pheno_crit%lai_initmin(j)
+
+       !
+       ! 19 maximum LAI
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       critical LAI above which no leaf allocation:', lai_max(j)
+
+       !
+       ! 20 fraction of primary leaf and root allocation put into reserve
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       reserve allocation factor:', ecureuil(j)
+
+       !
+       ! 21 maintenance respiration coefficient (g/g/day) at 0 deg C
+       !
+
+       coeff_maint_zero(j,ileaf) = cm_zero_leaf_tab(j)
+       coeff_maint_zero(j,isapabove) = cm_zero_sapabove_tab(j)
+       coeff_maint_zero(j,isapbelow) = cm_zero_sapbelow_tab(j)
+       coeff_maint_zero(j,iheartabove) = cm_zero_heartabove_tab(j)
+       coeff_maint_zero(j,iheartbelow) = cm_zero_heartbelow_tab(j)
+       coeff_maint_zero(j,iroot) = cm_zero_root_tab(j)
+       coeff_maint_zero(j,ifruit) = cm_zero_fruit_tab(j)
+       coeff_maint_zero(j,icarbres) = cm_zero_carbres_tab(j)
+
+       IF ( bavard .GE. 1 ) THEN
+
+          WRITE(numout,*) '       maintenance respiration coefficient (g/g/day) at 0 deg C:'
+          WRITE(numout,*) '         . leaves: ',coeff_maint_zero(j,ileaf)
+          WRITE(numout,*) '         . sapwood above ground: ',coeff_maint_zero(j,isapabove)
+          WRITE(numout,*) '         . sapwood below ground: ',coeff_maint_zero(j,isapbelow)
+          WRITE(numout,*) '         . heartwood above ground: ',coeff_maint_zero(j,iheartabove)
+          WRITE(numout,*) '         . heartwood below ground: ',coeff_maint_zero(j,iheartbelow)
+          WRITE(numout,*) '         . roots: ',coeff_maint_zero(j,iroot)
+          WRITE(numout,*) '         . fruits: ',coeff_maint_zero(j,ifruit)
+          WRITE(numout,*) '         . carbohydrate reserve: ',coeff_maint_zero(j,icarbres)
+
+       ENDIF
+
+       !
+       ! 22 parameter for temperature sensitivity of maintenance respiration
+       !
+
+       maint_resp_slope(j,1) = maint_resp_slope1_tab(j)
+       maint_resp_slope(j,2) = maint_resp_slope2_tab(j)
+       maint_resp_slope(j,3) = maint_resp_slope3_tab(j)
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       temperature sensitivity of maintenance respiration (1/K) is'
+       WRITE(numout,*) '          a function of long term T (C):'
+       WRITE(numout,*) '          ',maint_resp_slope(j,1),' + T *',maint_resp_slope(j,2), &
+            ' + T^2 *',maint_resp_slope(j,3)
+
+       !
+       ! 23 natural ?
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       Natural:', natural(j)
+
+       !
+       ! 24 Vcmax et Vjmax
+       !
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       Maximum rate of carboxylation:', vcmax_opt(j)
+
+       IF ( bavard .GE. 1 ) &
+            WRITE(numout,*) '       Maximum rate of RUbp regeneration:', vjmax_opt(j)
+
+       !
+       ! 25 constants for photosynthesis temperatures
+       !
+
+       t_photo%t_min_a(j) = tphoto_min_a_tab(j)
+       t_photo%t_min_b(j) = tphoto_min_b_tab(j)
+       t_photo%t_min_c(j) = tphoto_min_c_tab(j)
+       t_photo%t_opt_a(j) = tphoto_opt_a_tab(j)
+       t_photo%t_opt_b(j) = tphoto_opt_b_tab(j)
+       t_photo%t_opt_c(j) = tphoto_opt_c_tab(j)
+       t_photo%t_max_a(j) = tphoto_max_a_tab(j)
+       t_photo%t_max_b(j) = tphoto_max_b_tab(j)
+       t_photo%t_max_c(j) = tphoto_max_c_tab(j)
+
+       IF ( bavard .GE. 1 ) THEN
+          WRITE(numout,*) '       min. temperature for photosynthesis as a function of long term T (C):'
+          WRITE(numout,*) '          ',t_photo%t_min_c(j), &
+               ' + T*',t_photo%t_min_b(j), &
+               ' + T^2*',t_photo%t_min_a(j)
+          WRITE(numout,*) '       opt. temperature for photosynthesis as a function of long term T (C):'
+          WRITE(numout,*) '          ',t_photo%t_opt_c(j), &
+               ' + T*',t_photo%t_opt_b(j), &
+               ' + T^2*',t_photo%t_opt_a(j)
+          WRITE(numout,*) '       max. temperature for photosynthesis as a function of long term T (C):'
+          WRITE(numout,*) '          ',t_photo%t_max_c(j), &
+               ' + T*',t_photo%t_max_b(j), &
+               ' + T^2*',t_photo%t_max_a(j)
+
+          !
+          ! 26 Properties
+          !
+
+          WRITE(numout,*) '       Slope of the gs/A relation:', gsslope(j)
+          WRITE(numout,*) '       Intercept of the gs/A relation:', gsoffset(j)
+          WRITE(numout,*) '       C4 photosynthesis:', is_c4(j)
+          WRITE(numout,*) '       Depth constant for root profile (m):', 1./humcste(j)
+
+       ENDIF
+
+       !
+       ! 27 extinction coefficient of the Monsi&Seaki (53) relationship
+       !
+
+       ext_coeff(j) = ext_coef(j)
+
+       IF ( bavard .GE. 1 ) THEN
+          WRITE(numout,*) '       extinction coefficient:', ext_coeff(j)
+       ENDIF
+
+       !
+       ! 28 check coherence between tree definitions
+       !      this is not absolutely necessary (just security)
+       !
+
+       IF ( tree(j) .NEQV. is_tree(j) ) THEN
+          STOP 'Definition of tree/not tree not coherent'
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 29 time scales for phenology and other processes (in days)
+    !
+
+    pheno_crit%tau_hum_month = 20.            ! (!)
+
+    pheno_crit%tau_hum_week = 7.
+
+    pheno_crit%tau_t2m_month = 20.            ! (!)
+
+    pheno_crit%tau_t2m_week = 7.
+
+    pheno_crit%tau_tsoil_month = 20.          ! (!)
+
+    pheno_crit%tau_soilhum_month = 20.        ! (!)
+
+    pheno_crit%tau_gpp_week = 7.
+
+    pheno_crit%tau_gdd = 40.
+
+    pheno_crit%tau_ngd = 50.
+
+    pheno_crit%tau_longterm = 3. * one_year
+
+    IF ( bavard .GE. 1 ) THEN
+
+       WRITE(numout,*) '   > time scale for ''monthly'' moisture availability (d):', &
+            pheno_crit%tau_hum_month
+       WRITE(numout,*) '   > time scale for ''weekly'' moisture availability (d):', &
+            pheno_crit%tau_hum_week
+       WRITE(numout,*) '   > time scale for ''monthly'' 2 meter temperature (d):', &
+            pheno_crit%tau_t2m_month
+       WRITE(numout,*) '   > time scale for ''weekly'' 2 meter temperature (d):', &
+            pheno_crit%tau_t2m_week
+       WRITE(numout,*) '   > time scale for ''weekly'' GPP (d):', &
+            pheno_crit%tau_gpp_week
+       WRITE(numout,*) '   > time scale for ''monthly'' soil temperature (d):', &
+            pheno_crit%tau_tsoil_month
+       WRITE(numout,*) '   > time scale for ''monthly'' soil humidity (d):', &
+            pheno_crit%tau_soilhum_month
+       WRITE(numout,*) '   > time scale for vigour calculations (y):', &
+            pheno_crit%tau_longterm / one_year
+
+    ENDIF
+
+    !
+    ! 30 fraction of allocatable biomass which is lost as growth respiration
+    !
+
+    IF ( bavard .GE. 1 ) &
+         WRITE(numout,*) '   > growth respiration fraction:', frac_growthresp
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving data'
+
+  END SUBROUTINE data
+
+END MODULE stomate_data
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_io.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_io.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_io.f90	(revision 55)
@@ -0,0 +1,2011 @@
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_io.f90,v 1.18 2010/04/06 15:44:01 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_io
+  !---------------------------------------------------------------------
+  !- Not all variables saved in the start files are absolutely necessary.
+  !- However, Sechiba's and Stomate's PFTs are not necessarily identical,
+  !- and for that case this information needs to be saved.
+  !---------------------------------------------------------------------
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+  USE parallel
+  !-
+  IMPLICIT NONE
+  !-
+  PRIVATE
+  PUBLIC readstart, writerestart, readbc,get_reftemp_clear
+  !-
+  ! first call?
+  !-
+  LOGICAL,SAVE :: firstcall = .TRUE.
+  !-
+  ! reference temperature (K)
+  !-
+  REAL(r_std),ALLOCATABLE,DIMENSION(:),SAVE :: trefe
+  !-
+CONTAINS
+  !-
+  !===
+  !-
+  SUBROUTINE readstart &
+       & (npts, index, lalo, resolution, day_counter, dt_days, date, &
+       &  ind, adapted, regenerate, moiavail_daily, litterhum_daily, &
+       &  t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
+       &  soilhum_daily, precip_daily, &
+       &  gpp_daily, npp_daily, turnover_daily, &
+       &  moiavail_month, moiavail_week, t2m_longterm, tlong_ref, &
+       &  t2m_month, t2m_week, tsoil_month, soilhum_month, &
+       &  fireindex, firelitter, &
+       &  maxmoiavail_lastyear, maxmoiavail_thisyear, &
+       &  minmoiavail_lastyear, minmoiavail_thisyear, &
+       &  maxgppweek_lastyear, maxgppweek_thisyear, &
+       &  gdd0_lastyear, gdd0_thisyear, precip_lastyear, precip_thisyear, &
+       &  gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+       &  PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
+       &  maxfpc_lastyear, maxfpc_thisyear, &
+       &  turnover_longterm, gpp_week, biomass, resp_maint_part, &
+       &  leaf_age, leaf_frac, senescence, when_growthinit, age, &
+       &  resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
+       &  veget_lastlight, everywhere, need_adjacent, RIP_time, &
+       &  time_lowgpp, time_hum_min, hum_min_dormance, &
+       &  litterpart, litter, dead_leaves, &
+       &  carbon, black_carbon, lignin_struc,turnover_time, &
+       &  prod10,prod100,flux10, flux100, &
+       &  convflux, cflux_prod10, cflux_prod100, bm_to_litter)
+    !---------------------------------------------------------------------
+    !- read start file
+    !---------------------------------------------------------------------
+    !-
+    ! 0 declarations
+    !-
+    ! 0.1 input
+    !-
+    ! Domain size
+    INTEGER(i_std),INTENT(in) :: npts
+    ! Indices of the points on the map
+    INTEGER(i_std),DIMENSION(npts),INTENT(in) :: index
+    ! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std),DIMENSION(npts,2),INTENT(in) :: lalo
+    ! size in x an y of the grid (m)
+    REAL(r_std),DIMENSION(npts,2),INTENT(in) :: resolution
+    !-
+    ! 0.2 output
+    !-
+    ! counts time until next STOMATE time step
+    REAL(r_std),INTENT(out) :: day_counter
+    ! time step of STOMATE in days
+    REAL(r_std),INTENT(out) :: dt_days
+    ! date (d)
+    INTEGER(i_std),INTENT(out) :: date
+    ! density of individuals (1/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: ind
+    ! Winter too cold? between 0 and 1
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: adapted
+    ! Winter sufficiently cold? between 0 and 1
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: regenerate
+    ! daily moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: moiavail_daily
+    ! daily litter humidity
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: litterhum_daily
+    ! daily 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: t2m_daily
+    ! daily minimum 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: t2m_min_daily
+    ! daily surface temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: tsurf_daily
+    ! daily soil temperatures (K)
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: tsoil_daily
+    ! daily soil humidity
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: soilhum_daily
+    ! daily precipitations (mm/day) (for phenology)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: precip_daily
+    ! daily gross primary productivity (gC/m**2/day)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: gpp_daily
+    ! daily net primary productivity (gC/m**2/day)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: npp_daily
+    ! daily turnover rates (gC/m**2/day)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(out) :: turnover_daily
+    ! "monthly" moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: moiavail_month
+    ! "weekly" moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: moiavail_week
+    ! "long term" 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: t2m_longterm
+    ! "monthly" 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: t2m_month
+    ! "weekly" 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: t2m_week
+    ! "monthly" soil temperatures (K)
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: tsoil_month
+    ! "monthly" soil humidity
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(out) :: soilhum_month
+    ! Probability of fire
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: fireindex
+    ! Longer term total litter above the ground, gC/m**2 of ground
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: firelitter
+    ! last year's maximum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: maxmoiavail_lastyear
+    ! this year's maximum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: maxmoiavail_thisyear
+    ! last year's minimum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: minmoiavail_lastyear
+    ! this year's minimum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: minmoiavail_thisyear
+    ! last year's maximum weekly GPP
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: maxgppweek_lastyear
+    ! this year's maximum weekly GPP
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: maxgppweek_thisyear
+    ! last year's annual GDD0
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: gdd0_lastyear
+    ! this year's annual GDD0
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: gdd0_thisyear
+    ! last year's annual precipitation (mm/year)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: precip_lastyear
+    ! this year's annual precipitation (mm/year)
+    REAL(r_std),DIMENSION(npts),INTENT(out)      :: precip_thisyear
+    ! growing degree days, threshold -5 deg C (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: gdd_m5_dormance
+    ! growing degree days since midwinter (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: gdd_midwinter
+    ! number of chilling days since leaves were lost (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: ncd_dormance
+    ! number of growing days, threshold -5 deg C (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: ngd_minus5
+    ! PFT exists (equivalent to fpc_max > 0 for natural PFTs)
+    LOGICAL,DIMENSION(npts,nvm),INTENT(out)    :: PFTpresent
+    ! "long term" net primary productivity (gC/m**2/year)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: npp_longterm
+    ! last year's maximum leaf mass, for each PFT (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: lm_lastyearmax
+    ! this year's maximum leaf mass, for each PFT (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: lm_thisyearmax
+    ! last year's maximum fpc for each natural PFT, on ground
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: maxfpc_lastyear
+    ! this year's maximum fpc for each PFT,
+    ! on *total* ground (see stomate_season)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: maxfpc_thisyear
+    ! "long term" turnover rate (gC/m**2/year)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(out) :: turnover_longterm
+    ! "weekly" GPP (gC/day/(m**2 covered)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: gpp_week
+    ! biomass (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(out) :: biomass
+    ! maintenance resp (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(out) :: resp_maint_part
+    ! leaf age (days)
+    REAL(r_std),DIMENSION(npts,nvm,nleafages),INTENT(out) :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std),DIMENSION(npts,nvm,nleafages),INTENT(out) :: leaf_frac
+    ! is the plant senescent ? 
+    !(only for deciduous trees - carbohydrate reserve)
+    LOGICAL,DIMENSION(npts,nvm),INTENT(out) :: senescence
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: when_growthinit
+    ! mean age (years)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: age
+    ! heterotrophic respiration (gC/day/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: resp_hetero
+    ! maintenance respiration (gC/day/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: resp_maint
+    ! growth respiration (gC/day/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: resp_growth
+    ! carbon emitted into the atmosphere by fire (living and dead biomass)
+    ! (in gC/m**2/time step)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: co2_fire
+    ! biomass uptaken (gC/(m**2 of total ground)/day)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: co2_to_bm_dgvm
+    ! vegetation fractions (on ground) after last light competition
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: veget_lastlight
+    ! is the PFT everywhere in the grid box or very localized
+    ! (after its introduction)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: everywhere
+    ! in order for this PFT to be introduced,
+    ! does it have to be present in an adjacent grid box?
+    LOGICAL,DIMENSION(npts,nvm),INTENT(out) :: need_adjacent
+    ! How much time ago was the PFT eliminated for the last time (y)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: RIP_time
+    ! duration of dormance (d)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: time_lowgpp
+    ! time elapsed since strongest moisture availability (d)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: time_hum_min
+    ! minimum moisture during dormance
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: hum_min_dormance
+    ! fraction of litter above the ground belonging to different PFTs
+    ! separated for natural and agricultural PFTs.
+    REAL(r_std),DIMENSION(npts,nvm,nlitt),INTENT(out) :: litterpart
+    ! metabolic and structural litter, natural and agricultural,
+    ! above and below ground (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nlitt,nvm,nlevs),INTENT(out):: litter
+    ! dead leaves on ground, per PFT, metabolic and structural,
+    ! in gC/(m**2 of ground)
+    REAL(r_std),DIMENSION(npts,nvm,nlitt),INTENT(out) :: dead_leaves
+    ! carbon pool: active, slow, or passive, (gC/m**2)
+    REAL(r_std),DIMENSION(npts,ncarb,nvm),INTENT(out) :: carbon
+    ! black carbon on the ground (gC/(m**2 of total ground))
+    REAL(r_std),DIMENSION(npts),INTENT(out)                 :: black_carbon
+    ! ratio Lignine/Carbon in structural litter, above and below ground,(gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm,nlevs),INTENT(out) :: lignin_struc
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(out) :: turnover_time
+    !-
+    ! 0.3 not necessarily output
+    !-
+    ! "long term" reference 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(inout) :: tlong_ref
+    !-
+    ! 0.4 local
+    !-
+    ! date, real
+    REAL(r_std) :: date_real
+    ! PFT exists (equivalent to fpc_max > 0 for natural PFTs), real
+    REAL(r_std),DIMENSION(npts,nvm) :: PFTpresent_real
+    ! is the plant senescent ?
+    ! (only for deciduous trees - carbohydrate reserve), real
+    REAL(r_std),DIMENSION(npts,nvm) :: senescence_real
+    ! in order for this PFT to be introduced,
+    ! does it have to be present in an adjacent grid box? - real
+    REAL(r_std),DIMENSION(npts,nvm) :: need_adjacent_real
+    ! To store variables names for I/O
+    CHARACTER(LEN=80) :: var_name
+    ! string suffix indicating an index
+    CHARACTER(LEN=10) :: part_str
+    ! string suffix indicating litter type
+    CHARACTER(LEN=3),DIMENSION(nlitt) :: litter_str
+    ! string suffix indicating level
+    CHARACTER(LEN=2),DIMENSION(nlevs) :: level_str
+    ! temporary storage
+    REAL(r_std),DIMENSION(1) :: xtmp
+    ! index
+    INTEGER(i_std) :: j,k,l,m
+    ! reference temperature (K)
+    REAL(r_std),DIMENSION(npts) :: tref
+
+    ! land cover change variables 
+    ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
+    ! (10 or 100 + 1 : input from year of land cover change)
+    REAL(r_std),DIMENSION(npts,0:10),INTENT(out)                           :: prod10
+    REAL(r_std),DIMENSION(npts,0:100),INTENT(out)                          :: prod100
+    ! annual release from the 10/100 year-turnover pool compartments
+    REAL(r_std),DIMENSION(npts,10),INTENT(out)                           :: flux10
+    REAL(r_std),DIMENSION(npts,100),INTENT(out)                          :: flux100
+    REAL(r_std), DIMENSION(npts), INTENT(out)                            :: convflux
+    REAL(r_std), DIMENSION(npts), INTENT(out)                            :: cflux_prod10
+    REAL(r_std), DIMENSION(npts), INTENT(out)                            :: cflux_prod100
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(out)                   :: bm_to_litter
+    !---------------------------------------------------------------------
+    IF (bavard >= 3) WRITE(numout,*) 'Entering readstart'
+    !-
+    ! 0 When the vegetation is dynamic,
+    !   the long-term reference temperature is prognostic.
+    !   In this case, it is read from the restart file.
+    !   If the corresponding field does not exist in the restart file,
+    !   read it from another file in order to initialize it correctly.
+    !-
+    CALL get_reftemp( npts, lalo, resolution, tref )
+    !-
+    ! 1 string definitions
+    !-
+    DO l=1,nlitt
+       IF     (l == imetabolic) THEN
+          litter_str(l) = 'met'
+       ELSEIF (l == istructural) THEN
+          litter_str(l) = 'str'
+       ELSE
+          STOP 'Define litter_str'
+       ENDIF
+    ENDDO
+    !-
+    DO l=1,nlevs
+       IF     (l == iabove) THEN
+          level_str(l) = 'ab'
+       ELSEIF (l == ibelow) THEN
+          level_str(l) = 'be'
+       ELSE
+          STOP 'Define level_str'
+       ENDIF
+    ENDDO
+    !-
+    ! 2 run control
+    !-
+    ! 2.1 day counter
+    !-
+    IF (is_root_prc) THEN
+       var_name = 'day_counter'
+       CALL restget (rest_id_stomate, var_name, 1   , 1     , 1, itime, &
+            &                 .TRUE., xtmp)
+       day_counter = xtmp(1)
+       IF (day_counter == val_exp) day_counter = un
+    ENDIF
+    CALL bcast(day_counter)
+    !-
+    ! 2.2 time step of STOMATE in days
+    !-
+    IF (is_root_prc) THEN
+       var_name = 'dt_days'
+       CALL restget (rest_id_stomate, var_name, 1   , 1     , 1, itime, &
+            &                 .TRUE., xtmp)
+       dt_days = xtmp(1)
+       IF (dt_days == val_exp) dt_days = un
+    ENDIF
+    CALL bcast(dt_days)
+    !-
+    ! 2.3 date
+    !-
+    IF (is_root_prc) THEN
+       var_name = 'date'
+       CALL restget (rest_id_stomate, var_name, 1   , 1     , 1, itime, &
+            &                 .TRUE., xtmp)
+       date_real = xtmp(1)
+       IF (date_real == val_exp) date_real = zero
+       date = NINT(date_real)
+    ENDIF
+    CALL bcast(date_real)
+    !-
+    ! 3 daily meteorological variables
+    !-
+    moiavail_daily(:,:) = val_exp
+    var_name = 'moiavail_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., moiavail_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(moiavail_daily(:,:) == val_exp)) moiavail_daily(:,:) = zero
+    !-
+    litterhum_daily(:) = val_exp
+    var_name = 'litterhum_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., litterhum_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(litterhum_daily(:) == val_exp)) litterhum_daily(:) = zero
+    !-
+    t2m_daily(:) = val_exp
+    var_name = 't2m_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &                .TRUE., t2m_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(t2m_daily(:) == val_exp)) t2m_daily(:) = zero
+    !-
+    t2m_min_daily(:) = val_exp
+    var_name = 't2m_min_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &                .TRUE., t2m_min_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(t2m_min_daily(:) == val_exp)) t2m_min_daily(:) = large_value
+    !-
+    tsurf_daily(:) = val_exp
+    var_name = 'tsurf_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &                .TRUE., tsurf_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(tsurf_daily(:) == val_exp)) tsurf_daily(:) = tref(:)
+    !-
+    tsoil_daily(:,:) = val_exp
+    var_name = 'tsoil_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo,   nbdl, 1, itime, &
+         &                .TRUE., tsoil_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(tsoil_daily(:,:) == val_exp)) tsoil_daily(:,:) = zero
+    !-
+    soilhum_daily(:,:) = val_exp
+    var_name = 'soilhum_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo,   nbdl, 1, itime, &
+         &                .TRUE., soilhum_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(soilhum_daily(:,:) == val_exp)) soilhum_daily(:,:) = zero
+    !-
+    precip_daily(:) = val_exp
+    var_name = 'precip_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &                .TRUE., precip_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(precip_daily(:) == val_exp)) precip_daily(:) = zero
+    !-
+    ! 4 productivities
+    !-
+    gpp_daily(:,:) = val_exp
+    var_name = 'gpp_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., gpp_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(gpp_daily(:,:) == val_exp)) gpp_daily(:,:) = zero
+    !-
+    npp_daily(:,:) = val_exp
+    var_name = 'npp_daily'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., npp_daily, 'gather', nbp_glo, index_g)
+    IF (ALL(npp_daily(:,:) == val_exp)) npp_daily(:,:) = zero
+    !-
+    turnover_daily(:,:,:) = val_exp
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF (k < 10) part_str(1:1) = '0'
+       var_name = 'turnover_daily_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                .TRUE., turnover_daily(:,:,k), 'gather', nbp_glo, index_g)
+       IF (ALL(turnover_daily(:,:,k) == val_exp)) &
+            &       turnover_daily(:,:,k) = zero
+    ENDDO
+    !-
+    ! 5 monthly meteorological variables
+    !-
+    moiavail_month(:,:) = val_exp
+    var_name = 'moiavail_month'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., moiavail_month, 'gather', nbp_glo, index_g)
+    IF (ALL(moiavail_month(:,:) == val_exp)) moiavail_month(:,:) = zero
+    !-
+    moiavail_week(:,:) = val_exp
+    var_name = 'moiavail_week'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., moiavail_week, 'gather', nbp_glo, index_g)
+    IF (ALL(moiavail_week(:,:) == val_exp)) moiavail_week(:,:) = zero
+    !-
+    t2m_longterm(:) = val_exp
+    var_name = 't2m_longterm'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., t2m_longterm, 'gather', nbp_glo, index_g)
+    IF (ALL(t2m_longterm(:) == val_exp)) t2m_longterm(:) = tref(:)
+    !-
+    ! the long-term reference temperature is a prognostic variable
+    ! only in case the vegetation is dynamic
+    !-
+    IF (control%ok_dgvm) THEN
+       tlong_ref(:) = val_exp
+       var_name = 'tlong_ref'
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+            &                .TRUE., tlong_ref, 'gather', nbp_glo, index_g)
+       IF (ALL(tlong_ref(:) == val_exp)) tlong_ref(:) = tref(:)
+    ENDIF
+    !-
+    t2m_month(:) = val_exp
+    var_name = 't2m_month'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., t2m_month, 'gather', nbp_glo, index_g)
+    IF (ALL(t2m_month(:) == val_exp)) t2m_month(:) = tref(:)
+    !-
+    t2m_week(:) = val_exp
+    var_name = 't2m_week'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., t2m_week, 'gather', nbp_glo, index_g)
+    IF (ALL(t2m_week(:) == val_exp)) t2m_week(:) = tref(:)
+    !-
+    tsoil_month(:,:) = val_exp
+    var_name = 'tsoil_month'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo,   nbdl, 1, itime, &
+         &              .TRUE., tsoil_month, 'gather', nbp_glo, index_g)
+
+    IF (ALL(tsoil_month(:,:) == val_exp)) THEN
+       DO l=1,nbdl
+          tsoil_month(:,l) = tref(:)
+       ENDDO
+    ENDIF
+    !-
+    soilhum_month(:,:) = val_exp
+    var_name = 'soilhum_month'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo,   nbdl, 1, itime, &
+         &              .TRUE., soilhum_month, 'gather', nbp_glo, index_g)
+    IF (ALL(soilhum_month(:,:) == val_exp)) soilhum_month(:,:) = zero
+    !-
+    ! 6 fire probability
+    !-
+    fireindex(:,:) = val_exp
+    var_name = 'fireindex'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &              .TRUE., fireindex, 'gather', nbp_glo, index_g)
+    IF (ALL(fireindex(:,:) == val_exp)) fireindex(:,:) = zero
+    !-
+    firelitter(:,:) = val_exp
+    var_name = 'firelitter'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &              .TRUE., firelitter, 'gather', nbp_glo, index_g)
+    IF (ALL(firelitter(:,:) == val_exp)) firelitter(:,:) = zero
+    !-
+    ! 7 maximum and minimum moisture availabilities for tropic phenology
+    !-
+    maxmoiavail_lastyear(:,:) = val_exp
+    var_name = 'maxmoistr_last'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., maxmoiavail_lastyear, 'gather', nbp_glo, index_g)
+    IF (ALL(maxmoiavail_lastyear(:,:) == val_exp)) &
+         &     maxmoiavail_lastyear(:,:) = zero
+    !-
+    maxmoiavail_thisyear(:,:) = val_exp
+    var_name = 'maxmoistr_this'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., maxmoiavail_thisyear, 'gather', nbp_glo, index_g)
+    IF (ALL(maxmoiavail_thisyear(:,:) == val_exp)) &
+         &     maxmoiavail_thisyear(:,:) = zero
+    !-
+    minmoiavail_lastyear(:,:) = val_exp
+    var_name = 'minmoistr_last'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., minmoiavail_lastyear, 'gather', nbp_glo, index_g)
+    IF (ALL(minmoiavail_lastyear(:,:) == val_exp)) &
+         &     minmoiavail_lastyear(:,:) = un
+    !-
+    minmoiavail_thisyear(:,:) = val_exp
+    var_name = 'minmoistr_this'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., minmoiavail_thisyear, 'gather', nbp_glo, index_g)
+    IF (ALL( minmoiavail_thisyear(:,:) == val_exp)) &
+         &     minmoiavail_thisyear(:,:) = un
+    !-
+    ! 8 maximum "weekly" GPP
+    !-
+    maxgppweek_lastyear(:,:) = val_exp
+    var_name = 'maxgppweek_lastyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., maxgppweek_lastyear, 'gather', nbp_glo, index_g)
+    IF (ALL(maxgppweek_lastyear(:,:) == val_exp)) &
+         &     maxgppweek_lastyear(:,:) = zero
+    !-
+    maxgppweek_thisyear(:,:) = val_exp
+    var_name = 'maxgppweek_thisyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., maxgppweek_thisyear, 'gather', nbp_glo, index_g)
+    IF (ALL(maxgppweek_thisyear(:,:) == val_exp)) &
+         &     maxgppweek_thisyear(:,:) = zero
+    !-
+    ! 9 annual GDD0
+    !-
+    gdd0_thisyear(:) = val_exp
+    var_name = 'gdd0_thisyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., gdd0_thisyear, 'gather', nbp_glo, index_g)
+    IF (ALL(gdd0_thisyear(:) == val_exp)) gdd0_thisyear(:) = zero
+    !-
+    gdd0_lastyear(:) = val_exp
+    var_name = 'gdd0_lastyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., gdd0_lastyear, 'gather', nbp_glo, index_g)
+    IF (ALL(gdd0_lastyear(:) == val_exp)) gdd0_lastyear(:) = gdd_crit
+    !-
+    ! 10 annual precipitation
+    !-
+    precip_thisyear(:) = val_exp
+    var_name = 'precip_thisyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., precip_thisyear, 'gather', nbp_glo, index_g)
+    IF (ALL(precip_thisyear(:) == val_exp)) precip_thisyear(:) = zero
+    !-
+    precip_lastyear(:) = val_exp
+    var_name = 'precip_lastyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., precip_lastyear, 'gather', nbp_glo, index_g)
+    IF (ALL(precip_lastyear(:) == val_exp)) &
+         &     precip_lastyear(:) = precip_crit
+    !-
+    ! 11 derived "biometeorological" variables
+    !-
+    gdd_m5_dormance(:,:) = val_exp
+    var_name = 'gdd_m5_dormance'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., gdd_m5_dormance, 'gather', nbp_glo, index_g)
+    IF (ALL(gdd_m5_dormance(:,:) == val_exp)) &
+         &     gdd_m5_dormance(:,:) = undef
+    !-
+    gdd_midwinter(:,:) = val_exp
+    var_name = 'gdd_midwinter'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., gdd_midwinter, 'gather', nbp_glo, index_g)
+    IF (ALL(gdd_midwinter(:,:) == val_exp)) gdd_midwinter(:,:) = undef
+    !-
+    ncd_dormance(:,:) = val_exp
+    var_name = 'ncd_dormance'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., ncd_dormance, 'gather', nbp_glo, index_g)
+    IF (ALL(ncd_dormance(:,:) == val_exp)) ncd_dormance(:,:) = undef
+    !-
+    ngd_minus5(:,:) = val_exp
+    var_name = 'ngd_minus5'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., ngd_minus5, 'gather', nbp_glo, index_g)
+    IF (ALL(ngd_minus5(:,:) == val_exp)) ngd_minus5(:,:) = zero
+    !-
+    time_lowgpp(:,:) = val_exp
+    var_name = 'time_lowgpp'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., time_lowgpp, 'gather', nbp_glo, index_g)
+    IF (ALL(time_lowgpp(:,:) == val_exp)) time_lowgpp(:,:) = zero
+    !-
+    time_hum_min(:,:) = val_exp
+    var_name = 'time_hum_min'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., time_hum_min, 'gather', nbp_glo, index_g)
+    IF (ALL(time_hum_min(:,:) == val_exp)) time_hum_min(:,:) = undef
+    !-
+    hum_min_dormance(:,:) = val_exp
+    var_name = 'hum_min_dormance'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., hum_min_dormance, 'gather', nbp_glo, index_g)
+    IF (ALL(hum_min_dormance(:,:) == val_exp)) &
+         &     hum_min_dormance(:,:) = undef
+    !-
+    ! 12 Plant status
+    !-
+    PFTpresent_real(:,:) = val_exp
+    var_name = 'PFTpresent'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., PFTpresent_real, 'gather', nbp_glo, index_g)
+    IF (ALL(PFTpresent_real(:,:) == val_exp)) PFTpresent_real(:,:) = zero
+    WHERE (PFTpresent_real(:,:) >= .5)
+       PFTpresent = .TRUE.
+    ELSEWHERE
+       PFTpresent = .FALSE.
+    ENDWHERE
+    !-
+    ind(:,:) = val_exp
+    var_name = 'ind'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., ind, 'gather', nbp_glo, index_g)
+    IF (ALL(ind(:,:) == val_exp)) ind(:,:) = zero
+    !-
+    adapted(:,:) = val_exp
+    var_name = 'adapted'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., adapted, 'gather', nbp_glo, index_g)
+    IF (ALL(adapted(:,:) == val_exp)) adapted(:,:) = zero
+    !-
+    regenerate(:,:) = val_exp
+    var_name = 'regenerate'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., regenerate, 'gather', nbp_glo, index_g)
+    IF (ALL(regenerate(:,:) == val_exp)) regenerate(:,:) = zero
+    !-
+    npp_longterm(:,:) = val_exp
+    var_name = 'npp_longterm'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., npp_longterm, 'gather', nbp_glo, index_g)
+    IF (ALL(npp_longterm(:,:) == val_exp)) npp_longterm(:,:) = zero
+    !-
+    lm_lastyearmax(:,:) = val_exp
+    var_name = 'lm_lastyearmax'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., lm_lastyearmax, 'gather', nbp_glo, index_g)
+    IF (ALL(lm_lastyearmax(:,:) == val_exp)) lm_lastyearmax(:,:) = zero
+    !-
+    lm_thisyearmax(:,:) = val_exp
+    var_name = 'lm_thisyearmax'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., lm_thisyearmax, 'gather', nbp_glo, index_g)
+    IF (ALL(lm_thisyearmax(:,:) == val_exp)) lm_thisyearmax(:,:) = zero
+    !-
+    maxfpc_lastyear(:,:) = val_exp
+    var_name = 'maxfpc_lastyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., maxfpc_lastyear, 'gather', nbp_glo, index_g)
+    IF (ALL(maxfpc_lastyear(:,:) == val_exp)) maxfpc_lastyear(:,:) = zero
+    !-
+    maxfpc_thisyear(:,:) = val_exp
+    var_name = 'maxfpc_thisyear'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., maxfpc_thisyear, 'gather', nbp_glo, index_g)
+    IF (ALL(maxfpc_thisyear(:,:) == val_exp)) maxfpc_thisyear(:,:) = zero
+    !-
+    turnover_time(:,:) = val_exp
+    var_name = 'turnover_time'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., turnover_time, 'gather', nbp_glo, index_g)
+    IF ( ALL( turnover_time(:,:) == val_exp)) turnover_time(:,:) = 100.
+    !-
+    turnover_longterm(:,:,:) = val_exp
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF ( k < 10 ) part_str(1:1) = '0'
+       var_name = 'turnover_longterm_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &              .TRUE., turnover_longterm(:,:,k), 'gather', nbp_glo, index_g)
+       IF (ALL(turnover_longterm(:,:,k) == val_exp)) &
+            &       turnover_longterm(:,:,k) = zero
+    ENDDO
+    !-
+    gpp_week(:,:) = val_exp
+    var_name = 'gpp_week'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &              .TRUE., gpp_week, 'gather', nbp_glo, index_g)
+    IF (ALL(gpp_week(:,:) == val_exp)) gpp_week(:,:) = zero
+    !-
+    biomass(:,:,:) = val_exp
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF ( k < 10 ) part_str(1:1) = '0'
+       var_name = 'biomass_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                   .TRUE., biomass(:,:,k), 'gather', nbp_glo, index_g)
+       IF (ALL(biomass(:,:,k) == val_exp)) biomass(:,:,k) = zero
+    ENDDO
+    !-
+    resp_maint_part(:,:,:) = val_exp
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF ( k < 10 ) part_str(1:1) = '0'
+       var_name = 'maint_resp_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                   .TRUE., resp_maint_part(:,:,k), 'gather', nbp_glo, index_g)
+       IF (ALL(resp_maint_part(:,:,k) == val_exp)) resp_maint_part(:,:,k) = zero
+    ENDDO
+    !-
+    leaf_age(:,:,:) = val_exp
+    DO m=1,nleafages
+       WRITE (part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       var_name = 'leaf_age_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                   .TRUE., leaf_age(:,:,m), 'gather', nbp_glo, index_g)
+       IF (ALL(leaf_age(:,:,m) == val_exp)) leaf_age(:,:,m) = zero
+    ENDDO
+    !-
+    leaf_frac(:,:,:) = val_exp
+    DO m=1,nleafages
+       WRITE(part_str,'(I2)') m
+       IF ( m < 10 ) part_str(1:1) = '0'
+       var_name = 'leaf_frac_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                  .TRUE., leaf_frac(:,:,m), 'gather', nbp_glo, index_g)
+       IF (ALL(leaf_frac(:,:,m) == val_exp)) leaf_frac(:,:,m) = zero
+    ENDDO
+    !-
+    senescence_real(:,:) = val_exp
+    var_name = 'senescence'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., senescence_real, 'gather', nbp_glo, index_g)
+    IF (ALL(senescence_real(:,:) == val_exp)) senescence_real(:,:) = zero
+    WHERE ( senescence_real(:,:) >= .5 )
+       senescence = .TRUE.
+    ELSEWHERE
+       senescence = .FALSE.
+    ENDWHERE
+    !-
+    when_growthinit(:,:) = val_exp
+    var_name = 'when_growthinit'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., when_growthinit, 'gather', nbp_glo, index_g)
+    IF (ALL(when_growthinit(:,:) == val_exp)) &
+         &     when_growthinit(:,:) = undef
+    !-
+    age(:,:) = val_exp
+    var_name = 'age'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., age, 'gather', nbp_glo, index_g)
+    IF (ALL(age(:,:) == val_exp)) age(:,:) = zero
+    !-
+    ! 13 CO2
+    !-
+    resp_hetero(:,:) = val_exp
+    var_name = 'resp_hetero'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                .TRUE., resp_hetero, 'gather', nbp_glo, index_g)
+    IF (ALL(resp_hetero(:,:) == val_exp)) resp_hetero(:,:) = zero
+    !-
+    resp_maint(:,:) = val_exp
+    var_name = 'resp_maint'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., resp_maint, 'gather', nbp_glo, index_g)
+    IF (ALL(resp_maint(:,:) == val_exp)) resp_maint(:,:) = zero
+    !-
+    resp_growth(:,:) = val_exp
+    var_name = 'resp_growth'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., resp_growth, 'gather', nbp_glo, index_g)
+    IF (ALL(resp_growth(:,:) == val_exp)) resp_growth(:,:) = zero
+    !-
+    co2_fire(:,:) = val_exp
+    var_name = 'co2_fire'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm     , 1, itime, &
+         &                .TRUE., co2_fire, 'gather', nbp_glo, index_g)
+    IF (ALL(co2_fire(:,:) == val_exp)) co2_fire(:,:) = zero
+    !-
+    co2_to_bm_dgvm(:,:) = val_exp
+    var_name = 'co2_to_bm_dgvm'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm     , 1, itime, &
+         &                .TRUE., co2_to_bm_dgvm, 'gather', nbp_glo, index_g)
+    IF (ALL(co2_to_bm_dgvm(:,:) == val_exp)) co2_to_bm_dgvm(:,:) = zero
+    !-
+    ! 14 vegetation distribution after last light competition
+    !-
+    veget_lastlight(:,:) = val_exp
+    var_name = 'veget_lastlight'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., veget_lastlight, 'gather', nbp_glo, index_g)
+    IF (ALL(veget_lastlight(:,:) == val_exp)) veget_lastlight(:,:) = zero
+    !-
+    ! 15 establishment criteria
+    !-
+    everywhere(:,:) = val_exp
+    var_name = 'everywhere'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., everywhere, 'gather', nbp_glo, index_g)
+    IF (ALL(everywhere(:,:) == val_exp)) everywhere(:,:) = zero
+    !-
+    need_adjacent_real(:,:) = val_exp
+    var_name = 'need_adjacent'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., need_adjacent_real, 'gather', nbp_glo, index_g)
+    IF (ALL(need_adjacent_real(:,:) == val_exp)) &
+         &     need_adjacent_real(:,:) = zero
+    WHERE ( need_adjacent_real(:,:) >= .5 )
+       need_adjacent = .TRUE.
+    ELSEWHERE
+       need_adjacent = .FALSE.
+    ENDWHERE
+    !-
+    RIP_time(:,:) = val_exp
+    var_name = 'RIP_time'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                .TRUE., RIP_time, 'gather', nbp_glo, index_g)
+    IF (ALL(RIP_time(:,:) == val_exp)) RIP_time(:,:) = large_value
+    !-
+    ! 16 black carbon
+    !-
+    black_carbon(:) = val_exp
+    var_name = 'black_carbon'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &                .TRUE., black_carbon, 'gather', nbp_glo, index_g)
+    IF (ALL(black_carbon(:) == val_exp)) black_carbon(:) = zero
+    !-
+    ! 17 litter
+    !-
+    litterpart(:,:,:) = val_exp
+    DO l=1,nlitt
+       var_name = 'litterpart_'//litter_str(l)
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                   .TRUE., litterpart(:,:,l), 'gather', nbp_glo, index_g)
+       IF (ALL(litterpart(:,:,l) == val_exp)) litterpart(:,:,l) = zero
+    ENDDO
+    !-
+    litter(:,:,:,:) = val_exp
+    DO l=1,nlevs
+       DO m=1,nvm
+          WRITE (part_str, '(I2)') m
+          IF (m<10) part_str(1:1)='0'
+          var_name = 'litter_'//part_str(1:LEN_TRIM(part_str))//'_'//level_str(l)
+          CALL restget_p (rest_id_stomate, var_name, nbp_glo, nlitt , 1, itime, &
+               &                     .TRUE., litter(:,:,m,l), 'gather', nbp_glo, index_g)
+          IF (ALL(litter(:,:,m,l) == val_exp)) litter(:,:,m,l) = zero
+       ENDDO
+    ENDDO
+    !-
+    dead_leaves(:,:,:) = val_exp
+    DO l=1,nlitt
+       var_name = 'dead_leaves_'//litter_str(l)
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                   .TRUE., dead_leaves(:,:,l), 'gather', nbp_glo, index_g)
+       IF (ALL(dead_leaves(:,:,l) == val_exp)) dead_leaves(:,:,l) = zero
+    ENDDO
+    !-
+    carbon(:,:,:) = val_exp
+    DO m=1,nvm
+       WRITE (part_str, '(I2)') m
+       IF (m<10) part_str(1:1)='0'
+       var_name = 'carbon_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, ncarb , 1, itime, &
+            &                   .TRUE., carbon(:,:,m), 'gather', nbp_glo, index_g)
+       IF (ALL(carbon(:,:,m) == val_exp)) carbon(:,:,m) = zero
+    ENDDO
+    !-
+    lignin_struc(:,:,:) = val_exp
+    DO l=1,nlevs
+       var_name = 'lignin_struc_'//level_str(l)
+       CALL restget_p &
+            &    (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &     .TRUE., lignin_struc(:,:,l), 'gather', nbp_glo, index_g)
+       IF (ALL(lignin_struc(:,:,l) == val_exp)) lignin_struc(:,:,l) = zero
+    ENDDO
+    !-
+    ! 18 land cover change
+    !-
+    prod10(:,:) = val_exp
+    var_name = 'prod10'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 11     , 1, itime, &
+         &                .TRUE., prod10, 'gather', nbp_glo, index_g)
+    IF (ALL(prod10(:,:) == val_exp)) prod10(:,:) = zero
+
+    prod100(:,:) = val_exp
+    var_name = 'prod100'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 101     , 1, itime, &
+         &                .TRUE., prod100, 'gather', nbp_glo, index_g)
+    IF (ALL(prod100(:,:) == val_exp)) prod100(:,:) = zero
+
+
+    flux10(:,:) = val_exp
+    var_name = 'flux10'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 10     , 1, itime, &
+         &                .TRUE., flux10, 'gather', nbp_glo, index_g)
+    IF (ALL(flux10(:,:) == val_exp)) flux10(:,:) = zero
+
+    flux100(:,:) = val_exp
+    var_name = 'flux100'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 100     , 1, itime, &
+         &                .TRUE., flux100, 'gather', nbp_glo, index_g)
+    IF (ALL(flux100(:,:) == val_exp)) flux100(:,:) = zero
+
+    convflux(:) = val_exp
+    var_name = 'convflux'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., convflux, 'gather', nbp_glo, index_g)
+    IF (ALL(convflux(:) == val_exp)) convflux(:) = zero
+
+    cflux_prod10(:) = val_exp
+    var_name = 'cflux_prod10'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., cflux_prod10, 'gather', nbp_glo, index_g)
+    IF (ALL(cflux_prod10(:) == val_exp)) cflux_prod10(:) = zero
+
+    cflux_prod100(:) = val_exp
+    var_name = 'cflux_prod100'
+    CALL restget_p (rest_id_stomate, var_name, nbp_glo, 1     , 1, itime, &
+         &              .TRUE., cflux_prod100, 'gather', nbp_glo, index_g)
+    IF (ALL(cflux_prod100(:) == val_exp)) cflux_prod100(:) = zero
+
+    bm_to_litter(:,:,:) = val_exp
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF ( k < 10 ) part_str(1:1) = '0'
+       var_name = 'bm_to_litter_'//part_str(1:LEN_TRIM(part_str))
+       CALL restget_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+            &                .TRUE., bm_to_litter(:,:,k), 'gather', nbp_glo, index_g)
+       IF (ALL(bm_to_litter(:,:,k) == val_exp)) bm_to_litter(:,:,k) = zero
+    ENDDO
+
+    !-
+
+    IF (bavard >= 4) WRITE(numout,*) 'Leaving readstart'
+    !-----------------------
+  END SUBROUTINE readstart
+  !-
+  !===
+  !-
+  SUBROUTINE writerestart &
+       & (npts, index, day_counter, dt_days, date, &
+       &  ind, adapted, regenerate, moiavail_daily, litterhum_daily, &
+       &  t2m_daily, t2m_min_daily, tsurf_daily, tsoil_daily, &
+       &  soilhum_daily, precip_daily, gpp_daily, npp_daily, &
+       &  turnover_daily, moiavail_month, moiavail_week, &
+       &  t2m_longterm, tlong_ref, t2m_month, t2m_week, &
+       &  tsoil_month, soilhum_month, fireindex, firelitter, &
+       &  maxmoiavail_lastyear, maxmoiavail_thisyear, &
+       &  minmoiavail_lastyear, minmoiavail_thisyear, &
+       &  maxgppweek_lastyear, maxgppweek_thisyear, &
+       &  gdd0_lastyear, gdd0_thisyear, precip_lastyear, precip_thisyear, &
+       &  gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+       &  PFTpresent, npp_longterm, lm_lastyearmax, lm_thisyearmax, &
+       &  maxfpc_lastyear, maxfpc_thisyear, &
+       &  turnover_longterm, gpp_week, biomass, resp_maint_part, &
+       &  leaf_age, leaf_frac, senescence, when_growthinit, age, &
+       &  resp_hetero, resp_maint, resp_growth, co2_fire, co2_to_bm_dgvm, &
+       &  veget_lastlight, everywhere, need_adjacent, RIP_time, &
+       &  time_lowgpp, time_hum_min, hum_min_dormance, &
+       &  litterpart, litter, dead_leaves, &
+       &  carbon, black_carbon, lignin_struc, turnover_time, &
+       &  prod10,prod100 ,flux10, flux100, &
+       &  convflux, cflux_prod10, cflux_prod100, bm_to_litter)
+
+    !---------------------------------------------------------------------
+    !- write restart file
+    !---------------------------------------------------------------------
+    !-
+    ! 0 declarations
+    !-
+    ! 0.1 input
+    !-
+    ! Domain size
+    INTEGER(i_std),INTENT(in) :: npts
+    ! Indices of the points on the map
+    INTEGER(i_std),DIMENSION(npts),INTENT(in) :: index
+    ! counts time until next STOMATE time step
+    REAL(r_std),INTENT(in) :: day_counter
+    ! time step of STOMATE in days
+    REAL(r_std),INTENT(in) :: dt_days
+    ! date (d)
+    INTEGER(i_std),INTENT(in) :: date
+    ! density of individuals (1/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: ind
+    ! Winter too cold? between 0 and 1
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: adapted
+    ! Winter sufficiently cold? between 0 and 1
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: regenerate
+    ! daily moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: moiavail_daily
+    ! daily litter humidity
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: litterhum_daily
+    ! daily 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_daily
+    ! daily minimum 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_min_daily
+    ! daily surface temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: tsurf_daily
+    ! daily soil temperatures (K)
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: tsoil_daily
+    ! daily soil humidity
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: soilhum_daily
+    ! daily precipitations (mm/day) (for phenology)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_daily
+    ! daily gross primary productivity (gC/m**2/day)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: gpp_daily
+    ! daily net primary productivity (gC/m**2/day)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: npp_daily
+    ! daily turnover rates (gC/m**2/day)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in) :: turnover_daily
+    ! "monthly" moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: moiavail_month
+    ! "weekly" moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: moiavail_week
+    ! "long term" 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_longterm
+    ! "long term" reference 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: tlong_ref
+    ! "monthly" 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_month
+    ! "weekly" 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: t2m_week
+    ! "monthly" soil temperatures (K)
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: tsoil_month
+    ! "monthly" soil humidity
+    REAL(r_std),DIMENSION(npts,nbdl),INTENT(in) :: soilhum_month
+    ! Probability of fire
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: fireindex
+    ! Longer term total litter above the ground, gC/m**2 of ground
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: firelitter
+    ! last year's maximum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: maxmoiavail_lastyear
+    ! this year's maximum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: maxmoiavail_thisyear
+    ! last year's minimum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: minmoiavail_lastyear
+    ! this year's minimum moisture availability
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: minmoiavail_thisyear
+    ! last year's maximum weekly GPP
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: maxgppweek_lastyear
+    ! this year's maximum weekly GPP
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: maxgppweek_thisyear
+    ! last year's annual GDD0
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: gdd0_lastyear
+    ! this year's annual GDD0
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: gdd0_thisyear
+    ! last year's annual precipitation (mm/year)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_lastyear
+    ! this year's annual precipitation (mm/year)
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: precip_thisyear
+    ! growing degree days, threshold -5 deg C (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: gdd_m5_dormance
+    ! growing degree days since midwinter (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: gdd_midwinter
+    ! number of chilling days since leaves were lost (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: ncd_dormance
+    ! number of growing days, threshold -5 deg C (for phenology)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: ngd_minus5
+    ! PFT exists (equivalent to fpc_max > 0 for natural PFTs)
+    LOGICAL,DIMENSION(npts,nvm),INTENT(in) :: PFTpresent
+    ! "long term" net primary productivity (gC/m**2/year)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: npp_longterm
+    ! last year's maximum leaf mass, for each PFT (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: lm_lastyearmax
+    ! this year's maximum leaf mass, for each PFT (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: lm_thisyearmax
+    ! last year's maximum fpc for each natural PFT, on ground
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: maxfpc_lastyear
+    ! this year's maximum fpc for each PFT,
+    ! on *total* ground (see stomate_season)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: maxfpc_thisyear
+    ! "long term" turnover rate (gC/m**2/year)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in) :: turnover_longterm
+    ! "weekly" GPP (gC/day/(m**2 covered)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: gpp_week
+    ! biomass (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in) :: biomass
+    ! maintenance respiration (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in) :: resp_maint_part
+    ! leaf age (days)
+    REAL(r_std),DIMENSION(npts,nvm,nleafages),INTENT(in) :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std),DIMENSION(npts,nvm,nleafages),INTENT(in) :: leaf_frac
+    ! is the plant senescent ?
+    ! (only for deciduous trees - carbohydrate reserve)
+    LOGICAL,DIMENSION(npts,nvm),INTENT(in) :: senescence
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: when_growthinit
+    ! mean age (years)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: age
+    ! heterotrophic respiration (gC/day/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: resp_hetero
+    ! maintenance respiration (gC/day/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: resp_maint
+    ! growth respiration (gC/day/m**2)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: resp_growth
+    ! carbon emitted into the atmosphere by fire (living and dead biomass)
+    ! (in gC/m**2/time step)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: co2_fire
+    ! biomass uptaken (gC/(m**2 of total ground)/day)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: co2_to_bm_dgvm
+    ! vegetation fractions (on ground) after last light competition
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: veget_lastlight
+    ! is the PFT everywhere in the grid box or very localized
+    ! (after its introduction)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: everywhere
+    ! in order for this PFT to be introduced,
+    ! does it have to be present in an adjacent grid box?
+    LOGICAL,DIMENSION(npts,nvm),INTENT(in) :: need_adjacent
+    ! How much time ago was the PFT eliminated for the last time (y)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: RIP_time
+    ! duration of dormance (d)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: time_lowgpp
+    ! time elapsed since strongest moisture availability (d)
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: time_hum_min
+    ! minimum moisture during dormance
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: hum_min_dormance
+    ! fraction of litter above the ground belonging to different PFTs
+    REAL(r_std),DIMENSION(npts,nvm,nlitt),INTENT(in) :: litterpart
+    ! metabolic and structural litter, above and below ground (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nlitt,nvm,nlevs),INTENT(in) :: litter
+    ! dead leaves on ground, per PFT, metabolic and structural,
+    ! in gC/(m**2 of ground)
+    REAL(r_std),DIMENSION(npts,nvm,nlitt),INTENT(in) :: dead_leaves
+    ! carbon pool: active, slow, or passive, (gC/m**2)
+    REAL(r_std),DIMENSION(npts,ncarb,nvm),INTENT(in) :: carbon
+    ! black carbon on the ground (gC/(m**2 of total ground))
+    REAL(r_std),DIMENSION(npts),INTENT(in) :: black_carbon
+    ! ratio Lignine/Carbon in structural litter, above and below ground, (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm,nlevs),INTENT(in) :: lignin_struc
+    ! turnover_time of leaves
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in) :: turnover_time
+    !-
+    ! 0.2 local
+    !-
+    ! date, real
+    REAL(r_std) :: date_real
+    ! PFT exists (equivalent to fpc_max > 0 for natural PFTs), real
+    REAL(r_std),DIMENSION(npts,nvm) :: PFTpresent_real
+    ! is the plant senescent ?
+    ! (only for deciduous trees - carbohydrate reserve), real
+    REAL(r_std),DIMENSION(npts,nvm) :: senescence_real
+    ! in order for this PFT to be introduced,
+    ! does it have to be present in an adjacent grid box? - real
+    REAL(r_std),DIMENSION(npts,nvm) :: need_adjacent_real
+    ! To store variables names for I/O
+    CHARACTER(LEN=80) :: var_name
+    ! string suffix indicating an index
+    CHARACTER(LEN=10) :: part_str
+    ! string suffix indicating litter type
+    CHARACTER(LEN=3),DIMENSION(nlitt) :: litter_str
+    ! string suffix indicating level
+    CHARACTER(LEN=2),DIMENSION(nlevs) :: level_str
+    ! temporary storage
+    REAL(r_std),DIMENSION(1) :: xtmp
+    ! index
+    INTEGER(i_std) :: j,k,l,m
+
+    ! land cover change variables 
+    ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
+    ! (10 or 100 + 1 : input from year of land cover change)
+    REAL(r_std),DIMENSION(npts,0:10),INTENT(in)                           :: prod10
+    REAL(r_std),DIMENSION(npts,0:100),INTENT(in)                          :: prod100
+    ! annual release from the 10/100 year-turnover pool compartments
+    REAL(r_std),DIMENSION(npts,10),INTENT(in)                           :: flux10
+    REAL(r_std),DIMENSION(npts,100),INTENT(in)                          :: flux100
+    REAL(r_std), DIMENSION(npts), INTENT(in)                            :: convflux
+    REAL(r_std), DIMENSION(npts), INTENT(in)                            :: cflux_prod10
+    REAL(r_std), DIMENSION(npts), INTENT(in)                            :: cflux_prod100
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in)                   :: bm_to_litter
+    !---------------------------------------------------------------------
+    IF (bavard >= 3) WRITE(numout,*) 'Entering writerestart'
+    !-
+    ! 1 string definitions
+    !-
+    DO l=1,nlitt
+       IF     (l == imetabolic) THEN
+          litter_str(l) = 'met'
+       ELSEIF (l == istructural) THEN
+          litter_str(l) = 'str'
+       ELSE
+          STOP 'Define litter_str'
+       ENDIF
+    ENDDO
+    !-
+    DO l=1,nlevs
+       IF     (l == iabove) THEN
+          level_str(l) = 'ab'
+       ELSEIF (l == ibelow) THEN
+          level_str(l) = 'be'
+       ELSE
+          STOP 'Define level_str'
+       ENDIF
+    ENDDO
+    !-
+    IF (is_root_prc) THEN
+       CALL ioconf_setatt ('UNITS','-')
+       CALL ioconf_setatt ('LONG_NAME',' ')
+    ENDIF
+    !-
+    ! 2 run control
+    !-
+    ! 2.1 day counter
+    !-
+    IF (is_root_prc) THEN
+       var_name = 'day_counter'
+       xtmp(1) = day_counter
+       CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
+    ENDIF
+    !-
+    ! 2.2 time step of STOMATE in days
+    !-
+    IF (is_root_prc) THEN
+       var_name = 'dt_days'
+       xtmp(1) = dt_days
+       CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
+    ENDIF
+    !-
+    ! 2.3 date
+    !-
+    IF (is_root_prc) THEN
+       var_name = 'date'
+       date_real = REAL(date,r_std)
+       xtmp(1) = date_real
+       CALL restput (rest_id_stomate, var_name, 1, 1, 1, itime, xtmp)
+    ENDIF
+    !-
+    ! 3 daily meteorological variables
+    !-
+    var_name = 'moiavail_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                moiavail_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'litterhum_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                litterhum_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 't2m_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                t2m_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 't2m_min_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                t2m_min_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'tsurf_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                tsurf_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'tsoil_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
+         &                tsoil_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'soilhum_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
+         &                soilhum_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'precip_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                precip_daily, 'scatter', nbp_glo, index_g)
+    !-
+    ! 4 productivities
+    !-
+    var_name = 'gpp_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                gpp_daily, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'npp_daily'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                npp_daily, 'scatter', nbp_glo, index_g)
+    !-
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF (k < 10) part_str(1:1) = '0'
+       var_name = 'turnover_daily_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   turnover_daily(:,:,k), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    ! 5 monthly meteorological variables
+    !-
+    var_name = 'moiavail_month'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                moiavail_month, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'moiavail_week'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                moiavail_week, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 't2m_longterm'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                t2m_longterm, 'scatter', nbp_glo, index_g)
+    !-
+    IF (control%ok_dgvm) THEN
+       var_name = 'tlong_ref'
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+            &                tlong_ref, 'scatter', nbp_glo, index_g)
+    ENDIF
+    !-
+    var_name = 't2m_month'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                t2m_month, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 't2m_week'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                t2m_week, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'tsoil_month'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
+         &                tsoil_month, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'soilhum_month'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nbdl, 1, itime, &
+         &                soilhum_month, 'scatter', nbp_glo, index_g)
+    !-
+    ! 6 fire probability
+    !-
+    var_name = 'fireindex'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                fireindex, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'firelitter'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                firelitter, 'scatter', nbp_glo, index_g)
+    !-
+    ! 7 maximum and minimum moisture availabilities for tropic phenology
+    !-
+    var_name = 'maxmoistr_last'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                maxmoiavail_lastyear, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'maxmoistr_this'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                maxmoiavail_thisyear, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'minmoistr_last'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                minmoiavail_lastyear, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'minmoistr_this'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                minmoiavail_thisyear, 'scatter', nbp_glo, index_g)
+    !-
+    ! 8 maximum "weekly" GPP
+    !-
+    var_name = 'maxgppweek_lastyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                maxgppweek_lastyear, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'maxgppweek_thisyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                maxgppweek_thisyear, 'scatter', nbp_glo, index_g)
+    !-
+    ! 9 annual GDD0
+    !-
+    var_name = 'gdd0_thisyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &                gdd0_thisyear, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'gdd0_lastyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &                gdd0_lastyear, 'scatter', nbp_glo, index_g)
+    !-
+    ! 10 annual precipitation
+    !-
+    var_name = 'precip_thisyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &                precip_thisyear, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'precip_lastyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &                precip_lastyear, 'scatter', nbp_glo, index_g)
+    !-
+    ! 11 derived "biometeorological" variables
+    !-
+    var_name = 'gdd_m5_dormance'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                gdd_m5_dormance, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'gdd_midwinter'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                gdd_midwinter, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'ncd_dormance'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                ncd_dormance, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'ngd_minus5'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                ngd_minus5, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'time_lowgpp'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                time_lowgpp, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'time_hum_min'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                time_hum_min, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'hum_min_dormance'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                hum_min_dormance, 'scatter', nbp_glo, index_g)
+    !-
+    ! 12 Plant status
+    !-
+    var_name = 'PFTpresent'
+    WHERE ( PFTpresent(:,:) )
+       PFTpresent_real = un
+    ELSEWHERE
+       PFTpresent_real = zero
+    ENDWHERE
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                PFTpresent_real, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'ind'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                ind, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'turnover_time'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                turnover_time, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'adapted'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                adapted, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'regenerate'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                regenerate, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'npp_longterm'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                npp_longterm, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'lm_lastyearmax'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                lm_lastyearmax, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'lm_thisyearmax'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                lm_thisyearmax, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'maxfpc_lastyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                maxfpc_lastyear, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'maxfpc_thisyear'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                maxfpc_thisyear, 'scatter', nbp_glo, index_g)
+    !-
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF (k < 10) part_str(1:1) = '0'
+       var_name = 'turnover_longterm_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   turnover_longterm(:,:,k), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    var_name = 'gpp_week'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                gpp_week, 'scatter', nbp_glo, index_g)
+    !-
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF (k < 10) part_str(1:1) = '0'
+       var_name = 'biomass_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   biomass(:,:,k), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF (k < 10) part_str(1:1) = '0'
+       var_name = 'maint_resp_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   resp_maint_part(:,:,k), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    DO m=1,nleafages
+       WRITE(part_str,'(I2)') m
+       IF (m < 10) part_str(1:1) = '0'
+       var_name = 'leaf_age_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                  leaf_age(:,:,m), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    DO m=1,nleafages
+       WRITE(part_str,'(I2)') m
+       IF (m < 10) part_str(1:1) = '0'
+       var_name = 'leaf_frac_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                   leaf_frac(:,:,m), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    var_name = 'senescence'
+    WHERE ( senescence(:,:) )
+       senescence_real = un
+    ELSEWHERE
+       senescence_real = zero
+    ENDWHERE
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                senescence_real, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'when_growthinit'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                when_growthinit, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'age'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm  , 1, itime, &
+         &                age, 'scatter', nbp_glo, index_g)
+    !-
+    ! 13 CO2
+    !-
+    var_name = 'resp_hetero'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                resp_hetero, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'resp_maint'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                resp_maint, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'resp_growth'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                resp_growth, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'co2_fire'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,  nvm, 1, itime, &
+         &                co2_fire, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'co2_to_bm_dgvm'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                co2_to_bm_dgvm, 'scatter', nbp_glo, index_g)
+    !-
+    ! 14 vegetation distribution after last light competition
+    !-
+    var_name = 'veget_lastlight'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                veget_lastlight, 'scatter', nbp_glo, index_g)
+    !-
+    ! 15 establishment criteria
+    !-
+    var_name = 'everywhere'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                everywhere, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'need_adjacent'
+    WHERE (need_adjacent(:,:))
+       need_adjacent_real = un
+    ELSEWHERE
+       need_adjacent_real = zero
+    ENDWHERE
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                need_adjacent_real, 'scatter', nbp_glo, index_g)
+    !-
+    var_name = 'RIP_time'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+         &                RIP_time, 'scatter', nbp_glo, index_g)
+    !-
+    ! 16 black carbon
+    !-
+    var_name = 'black_carbon'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo,    1, 1, itime, &
+         &                black_carbon, 'scatter', nbp_glo, index_g)
+    !-
+    ! 17 litter
+    !-
+    DO l=1,nlitt
+       var_name = 'litterpart_'//litter_str(l)
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo,  nvm, 1, itime, &
+            &                   litterpart(:,:,l), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    DO l=1,nlevs
+       DO m=1,nvm
+          WRITE (part_str, '(I2)') m
+          IF (m<10) part_str(1:1)='0'
+          var_name = 'litter_'//part_str(1:LEN_TRIM(part_str))//'_'//level_str(l)
+          CALL restput_p (rest_id_stomate, var_name, nbp_glo, nlitt, 1, itime, &
+               &                     litter(:,:,m,l), 'scatter', nbp_glo, index_g)
+       ENDDO
+    ENDDO
+    !-
+    DO l=1,nlitt
+       var_name = 'dead_leaves_'//litter_str(l)
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo,  nvm, 1, itime, &
+            &                   dead_leaves(:,:,l), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    DO m=1,nvm
+       WRITE (part_str, '(I2)') m
+       IF (m<10) part_str(1:1)='0'
+       var_name = 'carbon_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, ncarb, 1, itime, &
+            &                   carbon(:,:,m), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    DO l=1,nlevs
+       var_name = 'lignin_struc_'//level_str(l)
+       CALL restput_p &
+            &      (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &       lignin_struc(:,:,l), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    ! 18 land cover change
+    !-
+    var_name = 'prod10'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 11, 1, itime, &
+         &                prod10, 'scatter', nbp_glo, index_g)
+    var_name = 'prod100'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 101, 1, itime, &
+         &                prod100, 'scatter', nbp_glo, index_g)
+    var_name = 'flux10'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 10, 1, itime, &
+         &                flux10, 'scatter', nbp_glo, index_g)
+    var_name = 'flux100'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 100, 1, itime, &
+         &                flux100, 'scatter', nbp_glo, index_g)
+
+    var_name = 'convflux'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &              convflux, 'scatter', nbp_glo, index_g)
+    var_name = 'cflux_prod10'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &              cflux_prod10, 'scatter', nbp_glo, index_g)
+    var_name = 'cflux_prod100'
+    CALL restput_p (rest_id_stomate, var_name, nbp_glo, 1, 1, itime, &
+         &              cflux_prod100, 'scatter', nbp_glo, index_g)
+    DO k=1,nparts
+       WRITE(part_str,'(I2)') k
+       IF (k < 10) part_str(1:1) = '0'
+       var_name = 'bm_to_litter_'//part_str(1:LEN_TRIM(part_str))
+       CALL restput_p (rest_id_stomate, var_name, nbp_glo, nvm, 1, itime, &
+            &                bm_to_litter(:,:,k), 'scatter', nbp_glo, index_g)
+    ENDDO
+    !-
+    IF (bavard >= 4) WRITE(numout,*) 'Leaving writerestart'
+    !--------------------------
+  END SUBROUTINE writerestart
+  !-
+  !===
+  !-
+  SUBROUTINE readbc (npts, lalo, resolution, tref)
+    !---------------------------------------------------------------------
+    !-
+    ! 0.1 input
+    !-
+    ! Domain size
+    INTEGER(i_std),INTENT(in) :: npts
+    ! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std),DIMENSION (npts,2),INTENT(in) :: lalo
+    ! size in x an y of the grid (m)
+    REAL(r_std),DIMENSION (npts,2),INTENT(in) :: resolution
+    !-
+    ! 0.2 not necessarily output
+    !-
+    ! "long term" reference 2 meter temperatures (K)
+    REAL(r_std),DIMENSION(npts),INTENT(inout) :: tref
+    !---------------------------------------------------------------------
+    !-
+    ! If the vegetation is static, then the long-term reference
+    ! temperature is a boundary condition.
+    !-
+    IF ( .NOT. control%ok_dgvm ) THEN
+       CALL get_reftemp (npts, lalo, resolution, tref)
+    ENDIF
+    !--------------------
+  END SUBROUTINE readbc
+  !-
+  !===
+  !-
+  SUBROUTINE get_reftemp_clear
+    !---------------------------------------------------------------------
+    firstcall=.TRUE.
+    IF (ALLOCATED (trefe)) DEALLOCATE( trefe )
+    !-------------------------------
+  END SUBROUTINE get_reftemp_clear
+  !-
+  !===
+  !-
+  SUBROUTINE get_reftemp (npts, lalo, resolution, tref_out)
+    !---------------------------------------------------------------------
+    !- read the long-term reference temperature from a boundary condition
+    !- file. If the vegetation is dynamic, this field is used to
+    !- initialize correctly the (prognostic) long-term reference
+    !- temperature (in the case it is not found in the restart file).
+    !- If the vegetation is static, the field read here is a real boundary
+    !- condition that is not modified by the model.
+    !---------------------------------------------------------------------
+    !-
+    ! 0 declarations
+    !-
+    ! 0.1 input
+    !-
+    ! Domain size
+    INTEGER(i_std),INTENT(in) :: npts
+    ! Geogr. coordinates (latitude,longitude) (degrees)
+    REAL(r_std),DIMENSION (npts,2),INTENT(in) :: lalo
+    ! size in x an y of the grid (m)
+    REAL(r_std),DIMENSION (npts,2),INTENT(in) :: resolution
+    !-
+    ! 0.2 output
+    !-
+    ! reference temperature (K)
+    REAL(r_std), DIMENSION(npts),INTENT(out) :: tref_out
+    !-
+    ! 0.3 local
+    !-
+    INTEGER(i_std),PARAMETER :: nbvmax=200
+    CHARACTER(LEN=80) :: filename
+    INTEGER(i_std) :: &
+         &  iml, jml, lml, tml, fid, ib, ip, jp, fopt, ilf, lastjp
+    REAL(r_std) :: lev(1), date, dt, coslat
+    INTEGER(i_std)                                 :: itau(1)
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: &
+         &  lat_rel, lon_rel, lat_ful, lon_ful, tref_file
+    REAL(r_std),ALLOCATABLE,DIMENSION(:,:) :: &
+         &  loup_rel, lolow_rel, laup_rel, lalow_rel
+    REAL(r_std) :: lon_up, lon_low, lat_up, lat_low
+    REAL(r_std) :: ax, ay, sgn
+    REAL(r_std),DIMENSION(nbvmax) :: area
+    REAL(r_std),DIMENSION(nbvmax) :: tt
+    REAL(r_std) :: m_pi
+    REAL(r_std) :: resx, resy
+    LOGICAL :: do_again
+    !---------------------------------------------------------------------
+    m_pi = 4. * ATAN(1.)
+    !-
+    ! 1 If this is the first call, calculate the reference temperature
+    !   and keep it in memory
+    !-
+    IF (firstcall) THEN
+       !---
+       !-- 1.1 only do this once
+       !---
+       firstcall = .FALSE.
+       !---
+       !-- 1.2 allocate the field
+       !---
+       ALLOCATE( trefe(npts) )
+       !---
+       !-- 1.3 read and interpolate the temperature file
+       !---
+       !-- Needs to be a configurable variable
+       !---
+       !Config Key  = REFTEMP_FILE
+       !Config Desc = Name of file from which the reference
+       !Config        temperature is read
+       !Config Def  = reftemp.nc
+       !Config Help = The name of the file to be opened to read
+       !Config        the reference surface temperature.
+       !Config        The data from this file is then interpolated
+       !Config        to the grid of of the model.
+       !Config        The aim is to get a reference temperature either
+       !Config        to initialize the corresponding prognostic model
+       !Config        variable correctly (ok_dgvm=TRUE) or to impose it
+       !Config        as boundary condition (ok_dgvm=FALSE)
+       !---
+       filename = 'reftemp.nc'
+       CALL getin_p('REFTEMP_FILE',filename)
+       !---
+       IF (is_root_prc) CALL flininfo(filename,iml, jml, lml, tml, fid)
+       CALL bcast(iml)
+       CALL bcast(jml)
+       CALL bcast(lml)
+       CALL bcast(tml)
+       !---
+       ALLOCATE (lat_rel(iml,jml))
+       ALLOCATE (lon_rel(iml,jml))
+       ALLOCATE (laup_rel(iml,jml))
+       ALLOCATE (loup_rel(iml,jml))
+       ALLOCATE (lalow_rel(iml,jml))
+       ALLOCATE (lolow_rel(iml,jml))
+       ALLOCATE (lat_ful(iml+2,jml+2))
+       ALLOCATE (lon_ful(iml+2,jml+2))
+       ALLOCATE (tref_file(iml,jml))
+       !---
+       IF (is_root_prc) CALL flinopen (filename, .FALSE., iml, jml, lml, &
+            &                                   lon_rel, lat_rel, lev, tml, itau, date, dt, fid)
+       CALL bcast(lon_rel)
+       CALL bcast(lat_rel)
+       CALL bcast(itau)
+       CALL bcast(date)
+       CALL bcast(dt)
+
+       !---
+       IF (is_root_prc) CALL flinget (fid, 'temperature', iml, jml, lml, tml, &
+            &                                  1, 1, tref_file)
+       CALL bcast(tref_file)
+       !---
+       IF (is_root_prc) CALL flinclo (fid)
+       !---
+       !-- Duplicate the border assuming we have a global grid
+       !-- going from west to east
+       !---
+       lon_ful(2:iml+1,2:jml+1) = lon_rel(1:iml,1:jml)
+       lat_ful(2:iml+1,2:jml+1) = lat_rel(1:iml,1:jml)
+       !---
+       IF ( lon_rel(iml,1) < lon_ful(2,2)) THEN
+          lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)
+          lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+       ELSE
+          lon_ful(1,2:jml+1) = lon_rel(iml,1:jml)-360
+          lat_ful(1,2:jml+1) = lat_rel(iml,1:jml)
+       ENDIF
+       !---
+       IF ( lon_rel(1,1) > lon_ful(iml+1,2)) THEN
+          lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)
+          lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+       ELSE
+          lon_ful(iml+2,2:jml+1) = lon_rel(1,1:jml)+360
+          lat_ful(iml+2,2:jml+1) = lat_rel(1,1:jml)
+       ENDIF
+       !---
+       sgn = lat_rel(1,1)/ABS(lat_rel(1,1))
+       lat_ful(2:iml+1,1) = sgn*180 - lat_rel(1:iml,1)
+       sgn = lat_rel(1,jml)/ABS(lat_rel(1,jml))
+       lat_ful(2:iml+1,jml+2) = sgn*180 - lat_rel(1:iml,jml)
+       lat_ful(1,1) = lat_ful(iml+1,1)
+       lat_ful(iml+2,1) = lat_ful(2,1)
+       lat_ful(1,jml+2) = lat_ful(iml+1,jml+2)
+       lat_ful(iml+2,jml+2) = lat_ful(2,jml+2)
+       !---
+       !-- Add the longitude lines to the top and bottom
+       !---
+       lon_ful(:,1) = lon_ful(:,2)
+       lon_ful(:,jml+2) = lon_ful(:,jml+1)
+       !---
+       !-- Get the upper and lower limits of each grid box
+       !---
+       DO ip=1,iml
+          DO jp=1,jml
+             loup_rel(ip,jp) = &
+                  &        MAX(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), &
+                  &            0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+             lolow_rel(ip,jp) = &
+                  &        MIN(0.5*(lon_ful(ip,jp+1)+lon_ful(ip+1,jp+1)), &
+                  &            0.5*(lon_ful(ip+1,jp+1)+lon_ful(ip+2,jp+1)))
+             laup_rel(ip,jp) = &
+                  &        MAX(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), &
+                  &            0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+             lalow_rel(ip,jp) = &
+                  &        MIN(0.5*(lat_ful(ip+1,jp)+lat_ful(ip+1,jp+1)), &
+                  &            0.5*(lat_ful(ip+1,jp+1)+lat_ful(ip+1,jp+2)))
+          ENDDO
+       ENDDO
+       !---
+       !-- Now we take each grid point and find out which values
+       !-- from the forcing we need to average
+       !---
+       DO ib=1,npts
+          !-----
+          resx = resolution(ib,1)
+          resy = resolution(ib,2)
+          !-----
+          do_again = .TRUE.
+          !-----
+          DO WHILE (do_again)
+             !-----
+             do_again = .FALSE.
+             !-------
+             !------ We find the 4 limits of the grid-box.
+             !------ As we transform the resolution of the model into longitudes
+             !------ and latitudes we do not have the problem of periodicity.
+             !------ coslat is a help variable here !
+             !-------
+             coslat = MAX(COS(lalo(ib,1)*m_pi/180.),0.001)*m_pi/180.*R_Earth
+             !-------
+             lon_up  = lalo(ib,2)+resx/(2.0*coslat)
+             lon_low = lalo(ib,2)-resx/(2.0*coslat)
+             !-------
+             coslat  = m_pi/180.*R_Earth
+             !-------
+             lat_up  = lalo(ib,1)+resy/(2.0*coslat)
+             lat_low = lalo(ib,1)-resy/(2.0*coslat)
+             !-------
+             !------ Find the grid boxes from the data that go into
+             !------ the model's boxes.
+             !------ We still work as if we had a regular grid !
+             !------ Well it needs to be localy regular so that
+             !------ the longitude at the latitude of the last found point
+             !------ is close to the one of the next point.
+             !-------
+             fopt = 0
+             lastjp = 1
+             DO ip=1,iml
+                !---------
+                !-------- Either the center of the data grid point is in the interval
+                !-------- of the model grid or the East and West limits of the data
+                !-------- grid point are on either sides of the border of the data grid
+                !---------
+                IF (      lon_rel(ip,lastjp) > lon_low &
+                     &            .AND. lon_rel(ip,lastjp) < lon_up &
+                     &             .OR. lolow_rel(ip,lastjp) < lon_low &
+                     &            .AND. loup_rel(ip,lastjp) > lon_low &
+                     &             .OR. lolow_rel(ip,lastjp) < lon_up &
+                     &            .AND. loup_rel(ip,lastjp) > lon_up ) THEN
+                   DO jp=1,jml
+                      !-------------
+                      !------------ Now that we have the longitude let us find the latitude
+                      !-------------
+                      IF (      lat_rel(ip,jp) > lat_low &
+                           &                 .AND. lat_rel(ip,jp) < lat_up &
+                           &                  .OR. lalow_rel(ip,jp) < lat_low &
+                           &                 .AND. laup_rel(ip,jp) > lat_low &
+                           &                  .OR. lalow_rel(ip,jp) < lat_up &
+                           &                 .AND. laup_rel(ip,jp) > lat_up) THEN
+                         lastjp = jp
+                         !---------------
+                         fopt = fopt + 1
+                         IF ( fopt > nbvmax) THEN
+                            WRITE(numout,*) &
+                                 &                       'Please increase nbvmax in subroutine get_reftemp',ib
+                            STOP
+                         ELSE
+                            !-----------------
+                            !---------------- Get the area of the fine grid in the model grid
+                            !-----------------
+                            coslat = MAX(COS(lat_rel(ip,jp)*m_pi/180.),0.001)
+                            ax =  ( MIN(lon_up,loup_rel(ip,jp)) &
+                                 &                       -MAX(lon_low,lolow_rel(ip,jp))) &
+                                 &                     *m_pi/180.*R_Earth*coslat
+                            ay =  ( MIN(lat_up,laup_rel(ip,jp)) &
+                                 &                       -MAX(lat_low,lalow_rel(ip,jp))) &
+                                 &                     *m_pi/180.*R_Earth
+                            area(fopt) = ax*ay
+                            tt(fopt) = tref_file(ip,jp)
+                         ENDIF
+                      ENDIF
+                   ENDDO
+                ENDIF
+             ENDDO
+             !-------
+             !------ Check that we found some points
+             !-------
+             trefe(ib) = zero
+             !-------
+             IF (fopt == 0) THEN
+                do_again = .TRUE.
+                !-------
+                !------ increase search radius
+                !-------
+                resx = resx*2.
+                resy = resy*2.
+                IF ( resx > 2.*m_pi*R_Earth .OR. resy > m_pi*R_Earth ) THEN
+                   STOP 'get_reftemp: found no point'
+                ENDIF
+             ELSE
+                sgn = zero
+                !-------
+                !------ Compute the average surface air temperature
+                !-------
+                DO ilf=1,fopt
+                   trefe(ib) = trefe(ib) + tt(ilf) * area(ilf)
+                   sgn = sgn + area(ilf)
+                ENDDO
+                !-------
+                !------ Normalize the surface
+                !-------
+                IF (sgn < min_sechiba) THEN
+                   do_again = .TRUE.
+                   !---------
+                   !-------- increase search radius
+                   !---------
+                   resx = resx * 2.
+                   resy = resy * 2.
+                   IF ( resx > 2.*m_pi*R_Earth .OR. resy > m_pi*R_Earth ) THEN
+                      STOP 'get_reftemp: found no point'
+                   ENDIF
+                ELSE
+                   trefe(ib) = trefe(ib) / sgn
+                ENDIF
+             ENDIF
+          ENDDO
+       ENDDO
+       !-
+       ! transform into Kelvin
+       !-
+       trefe(:) = trefe(:) + ZeroCelsius
+       !-
+       ! deallocate
+       !-
+       DEALLOCATE (lat_rel)
+       DEALLOCATE (lon_rel)
+       DEALLOCATE (laup_rel)
+       DEALLOCATE (loup_rel)
+       DEALLOCATE (lalow_rel)
+       DEALLOCATE (lolow_rel)
+       DEALLOCATE (lat_ful)
+       DEALLOCATE (lon_ful)
+       DEALLOCATE (tref_file)
+    ENDIF
+    !-
+    ! 2 output the reference temperature
+    !-
+    tref_out(:) = trefe(:)
+    !-------------------------
+  END SUBROUTINE get_reftemp
+  !-
+  !===
+  !-
+END MODULE stomate_io
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_lcchange.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_lcchange.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_lcchange.f90	(revision 55)
@@ -0,0 +1,342 @@
+! Stomate: Land cover change
+!
+! authors: M. Boisserie, P. Friedlingstein, P. Smith
+!
+!
+! 
+!
+! version 1.0: May 2008
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_lcchange.f90,v 1.6 2010/08/05 15:59:08 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_lcchange
+
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE stomate_data
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+
+  PRIVATE
+  PUBLIC lcchange_main
+
+CONTAINS
+
+  SUBROUTINE lcchange_main ( npts, dt_days, veget_max, veget_max_new,&
+       biomass, ind, age, PFTpresent, senescence, when_growthinit, everywhere, veget,&        
+       co2_to_bm, bm_to_litter, turnover_daily, bm_sapl, tree, cn_ind,flux10,flux100, &
+       prod10,prod100,&
+!!$,prod10_total,prod100_total,&
+       convflux,&
+!!$,cflux_prod_total,
+       cflux_prod10,cflux_prod100, leaf_frac,&
+       npp_longterm, lm_lastyearmax, litter, carbon)
+
+    IMPLICIT NONE
+    ! 0 declarations
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER, INTENT(in)                                            :: npts
+
+    ! Time step (days)
+    REAL(r_std), INTENT(in)                                         :: dt_days 
+
+    ! new "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(INOUT)                 :: veget_max_new
+    ! biomass of sapling (gC/individu)
+    REAL(r_std) , DIMENSION (nvm, nparts), INTENT(in)              :: bm_sapl
+
+    ! is pft a tree
+    LOGICAL, DIMENSION(nvm), INTENT(in)                           :: tree
+
+    ! 0.2 modified fields
+
+    ! fractional coverage on natural/agricultural ground, taking into
+    !   account LAI (=grid-scale fpc)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: veget
+
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: veget_max
+
+    ! biomass (gC/(m**2 of nat/agri ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)             :: biomass
+
+    ! density of individuals 1/m**2
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: ind
+
+    ! mean age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: age
+
+    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
+    !         set to .FALSE. if PFT is introduced or killed
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)                       :: senescence
+
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)                       :: PFTpresent
+
+    ! is the PFT everywhere in the grid box or very localized (after its introduction)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: everywhere
+
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: when_growthinit
+
+    ! biomass uptaken (gC/(m**2)/day)
+    !NV passage 2D
+
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                       :: co2_to_bm
+
+    ! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)           :: bm_to_litter
+
+    ! crown area (m**2) per ind.
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                   :: cn_ind
+
+    ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
+    ! (10 or 100 + 1 : input from year of land cover change)
+    REAL(r_std), DIMENSION(npts,0:10), INTENT(inout)                     :: prod10
+    REAL(r_std), DIMENSION(npts,0:100), INTENT(inout)                    :: prod100
+
+    ! annual release from the 10/100 year-turnover pool compartments
+    REAL(r_std), DIMENSION(npts,10), INTENT(inout)                     :: flux10
+    REAL(r_std), DIMENSION(npts,100), INTENT(inout)                    :: flux100 
+
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)         :: leaf_frac
+
+    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of nat/agri ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                   :: lm_lastyearmax
+
+    ! "long term" net primary productivity (gC/(m**2 of nat/agri ground)/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: npp_longterm
+
+    ! metabolic and structural litter, above and below ground (gC/(m**2 of ground))
+    REAL(r_std),DIMENSION(npts,nlitt,nvm,nlevs), INTENT(inout)         :: litter
+    !  carbon pool: active, slow, or passive,(gC/(m**2 of ground))
+    REAL(r_std),DIMENSION(npts,ncarb,nvm), INTENT(inout)               :: carbon
+
+    ! 0.3 output
+
+    ! release during first year following land cover change
+    REAL(r_std), DIMENSION(npts), INTENT(out)                          :: convflux
+
+    ! total annual release from the 10/100 year-turnover pool
+    REAL(r_std), DIMENSION(npts), INTENT(out)                          :: cflux_prod10, cflux_prod100
+
+!!$    ! total products remaining in the pool after the annual release 
+!!$    REAL(r_std), DIMENSION(npts), INTENT(out)                          :: prod10_total, prod100_total 
+!!$
+!!$    ! total flux from conflux and the 10/100 year-turnover pool 
+!!$    REAL(r_std), DIMENSION(npts), INTENT(out)                          :: cflux_prod_total
+
+    ! Turnover rates (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)               :: turnover_daily
+
+    ! 0.4 local
+
+    ! indices
+    INTEGER(i_std)                                                     :: i, j, k, l, m
+
+    ! biomass increase (gC/(m**2 of ground))
+    REAL(r_std)                                                        :: bm_new
+    ! biomass loss (gC /(m² of ground))
+    REAL(r_std),DIMENSION(npts,nparts)                                 :: biomass_loss
+    REAL(r_std)                                                        :: above
+    ! Litter dilution (gC/m²)
+    REAL(r_std),DIMENSION(npts,nlitt,nlevs)                            :: dilu_lit
+    ! Soil Carbondilution (gC/m²)
+    REAL(r_std),DIMENSION(npts,ncarb)                                  :: dilu_soil_carbon
+
+    ! vecteur de conversion
+    REAL(r_std),DIMENSION(nvm)                                         :: delta_veg
+    ! vecteur de conversion
+    REAL(r_std)                                                        :: delta_veg_sum
+    ! change in number of individuals 
+    REAL(r_std),DIMENSION(npts,nvm)                                    :: delta_ind 
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering lcchange_main'
+
+    ! yearly initialisation
+    prod10(:,0)           = zero
+    prod100(:,0)          = zero   
+    above                 = zero
+    convflux(:)           = zero
+    cflux_prod10(:)       = zero
+    cflux_prod100(:)      = zero
+!!$    prod10_total(:)       = zero
+!!$    prod100_total(:)      = zero
+!!$    cflux_prod_total(:)   = zero
+
+    delta_ind(:,:) = zero
+    delta_veg(:) = zero
+
+    DO i = 1, npts  
+
+       ! Génération du vecteur de conversion
+
+       delta_veg(:) = veget_max_new(i,:)-veget_max(i,:)
+       delta_veg_sum = SUM(delta_veg,MASK=delta_veg.LT.0.)
+
+       dilu_lit(i,:,:) = zero
+       dilu_soil_carbon(i,:) = zero
+       biomass_loss(i,:) = zero
+
+       DO j=2, nvm
+          IF ( delta_veg(j) < -min_stomate ) THEN 
+             dilu_lit(i,:,:)=  dilu_lit(i,:,:) + delta_veg(j)*litter(i,:,j,:) / delta_veg_sum
+             dilu_soil_carbon(i,:)=  dilu_soil_carbon(i,:) + delta_veg(j) * carbon(i,:,j) / delta_veg_sum
+             biomass_loss(i,:)=biomass_loss(i,:) + biomass(i,j,:)*delta_veg(j) / delta_veg_sum
+          ENDIF
+       ENDDO
+
+       DO j=2, nvm
+          IF ( delta_veg(j) > min_stomate) THEN
+             ! in case of establishment of a new PFT or extension of its coverage in a gridcell
+             IF (veget_max(i,j) .LT. min_stomate) THEN 
+                IF (tree(j)) THEN
+                   cn_ind(i,j) = cn_sapl(j)
+                ELSE
+                   cn_ind(i,j)=un
+                ENDIF
+                ind(i,j)= delta_veg(j) / cn_ind(i,j)
+                PFTpresent(i,j) = .TRUE.
+                everywhere(i,j) = un
+                senescence(i,j) = .FALSE.
+                age(i,j) = 0.
+
+                when_growthinit(i,j) = large_value
+                leaf_frac(i,j,1) = un
+                npp_longterm(i,j) = 10.
+                lm_lastyearmax(i,j) = bm_sapl(j,ileaf) * ind(i,j)
+             ENDIF
+             IF ( cn_ind(i,j) > min_stomate ) THEN
+                delta_ind(i,j) = delta_veg(j) / cn_ind(i,j) 
+             ENDIF
+
+             DO k = 1, nparts
+                !added shilong 060316
+                bm_new = delta_ind(i,j) * bm_sapl(j,k) 
+                IF (veget_max(i,j) .GT. min_stomate) THEN
+                   IF ((bm_new/delta_veg(j)) > biomass(i,j,k)) THEN
+                      bm_new = biomass(i,j,k)*delta_veg(j)
+                   ENDIF
+                ENDIF
+                biomass(i,j,k) = ( biomass(i,j,k) * veget_max(i,j) + bm_new )  / veget_max_new(i,j)
+                !NV passage 2D
+                co2_to_bm(i,j) = co2_to_bm(i,j)+  (bm_new* dt_days) / (one_year * veget_max_new(i,j))
+             ENDDO
+
+             ! Dilution des reservoirs
+
+             ! Litter
+             litter(i,:,j,:)=(litter(i,:,j,:) * veget_max(i,j) + &
+                  dilu_lit(i,:,:) * delta_veg(j)) / veget_max_new(i,j)
+
+             ! Soil carbon
+             carbon(i,:,j)=(carbon(i,:,j) * veget_max(i,j) + dilu_soil_carbon(i,:) * delta_veg(j)) / veget_max_new(i,j)
+
+             ! Litter input
+             bm_to_litter(i,j,isapbelow) = bm_to_litter(i,j,isapbelow) + &
+                  &                         biomass_loss(i,isapbelow)*delta_veg(j) / veget_max_new(i,j)
+             bm_to_litter(i,j,iheartbelow) = bm_to_litter(i,j,iheartbelow) + biomass_loss(i,iheartbelow) *delta_veg(j) &
+                  &  / veget_max_new(i,j)
+             bm_to_litter(i,j,iroot) = bm_to_litter(i,j,iroot) + biomass_loss(i,iroot)*delta_veg(j) / veget_max_new(i,j)
+             bm_to_litter(i,j,ifruit) = bm_to_litter(i,j,ifruit) + biomass_loss(i,ifruit)*delta_veg(j) / veget_max_new(i,j)
+             bm_to_litter(i,j,icarbres) = bm_to_litter(i,j,icarbres) + &
+                  &                         biomass_loss(i,icarbres)   *delta_veg(j) / veget_max_new(i,j)
+             bm_to_litter(i,j,ileaf) = bm_to_litter(i,j,ileaf) + biomass_loss(i,ileaf)*delta_veg(j) / veget_max_new(i,j)
+             age(i,j)=age(i,j)*veget_max(i,j)/veget_max_new(i,j)
+             !  End if PFT extension
+          ELSE  ! PFT in reduction
+
+             above = biomass(i,j,isapabove) + biomass(i,j,iheartabove)
+             convflux(i)  = convflux(i)  - ( coeff_lcchange_1(j) * above * delta_veg(j) ) ! - car delta_veg <0 
+             prod10(i,0)  = prod10(i,0)  - ( coeff_lcchange_10(j) * above * delta_veg(j) )
+             prod100(i,0) = prod100(i,0) - ( coeff_lcchange_100(j) * above * delta_veg(j) )
+
+             ! End Biomass Export
+
+             IF ( veget_max_new(i,j) .LT. min_stomate ) THEN ! Total reduction
+
+                veget_max_new(i,j)= zero
+                ind(i,j) = zero
+                biomass(i,j,:) = zero
+                PFTpresent(i,j) = .FALSE.
+                senescence(i,j) = .FALSE.
+                age(i,j) = zero
+                when_growthinit(i,j) = undef
+                everywhere(i,j) = zero
+                carbon(i,:,j) = zero
+                litter(i,:,j,:) = zero
+                bm_to_litter(i,j,:) = zero
+                turnover_daily(i,j,:) = zero
+
+             ENDIF
+
+          ENDIF   ! End if PFT's coverage reduction
+
+       ENDDO   ! End loop on PFTs
+
+       ! each year, update 10 year-turnover pool content following flux emission
+       ! (linear decay (10%) of the initial carbon input)
+       DO   l = 0, 8
+          m = 10 - l
+          cflux_prod10(i) =  cflux_prod10(i) + flux10(i,m)
+          prod10(i,m)     =  prod10(i,m-1)   - flux10(i,m-1)
+!MM=>stomate_lpj.f90          prod10_total(i) =  prod10_total(i) + prod10(i,m)
+          flux10(i,m)     =  flux10(i,m-1)
+
+          IF (prod10(i,m) .LT. 1.0) prod10(i,m) = 0.0
+!MM => quid de prod10_total ??? 
+       ENDDO
+
+       cflux_prod10(i) = cflux_prod10(i) + flux10(i,1) 
+       flux10(i,1)     = 0.1 * prod10(i,0)
+       prod10(i,1)     = prod10(i,0)
+!MM => quid du test IF (prod10(i,1) .LT. 1.0) prod10(i,1) = 0.0 ????
+!MM=>stomate_lpj.f90       prod10_total(i) = prod10_total(i)  + prod10(i,1)
+
+       DO   l = 0, 98
+          m = 100 - l
+          cflux_prod100(i)  =  cflux_prod100(i) + flux100(i,m)
+          prod100(i,m)      =  prod100(i,m-1)   - flux100(i,m-1)
+!MM=>stomate_lpj.f90          prod100_total(i)  =  prod100_total(i) + prod100(i,m)
+          flux100(i,m)      =  flux100(i,m-1)
+
+          IF (prod100(i,m).LT.1.0) prod100(i,m) = 0.0
+
+       ENDDO
+
+       cflux_prod100(i)  = cflux_prod100(i) + flux100(i,1) 
+       flux100(i,1)      = 0.01 * prod100(i,0)
+       prod100(i,1)      = prod100(i,0)
+!MM=>          IF (prod100(i,1).LT.1.0) prod100(i,1) = zero
+!MM=>stomate_lpj.f90       prod100_total(i)  = prod100_total(i) + prod100(i,1)
+       prod10(i,0)        = zero
+       prod100(i,0)       = zero
+
+    ENDDO  ! End loop on npts
+
+    veget_max(:,:) = veget_max_new(:,:)
+
+    ! convert flux from /year into /time step
+    convflux        = convflux/one_year*dt_days
+    cflux_prod10    = cflux_prod10/one_year*dt_days
+    cflux_prod100   = cflux_prod100/one_year*dt_days
+!MM=>stomate_lpj.f90    cflux_prod_total(:) = convflux(:) + cflux_prod10(:) + cflux_prod100(:)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving lcchange_main'
+
+  END SUBROUTINE lcchange_main
+
+END MODULE stomate_lcchange
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_litter.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_litter.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_litter.f90	(revision 55)
@@ -0,0 +1,695 @@
+! Update litter and lignine content after litter fall.
+! Calculate litter decomposition.
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_litter.f90,v 1.9 2009/06/24 10:43:21 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_litter
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC littercalc,littercalc_clear, deadleaf
+
+  ! first call
+  LOGICAL, SAVE                                                     :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE littercalc_clear
+    firstcall =.TRUE.
+  END SUBROUTINE littercalc_clear
+
+
+  SUBROUTINE littercalc (npts, dt, &
+       turnover, bm_to_litter, &
+       veget_max, tsurf, tsoil, soilhum, litterhum, &
+       litterpart, litter, dead_leaves, lignin_struc, &
+       deadleaf_cover, resp_hetero_litter, &
+       soilcarbon_input, control_temp, control_moist)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                               :: npts
+    ! time step in days
+    REAL(r_std), INTENT(in)                                            :: dt
+    ! Turnover rates (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)               :: turnover
+    ! conversion of biomass to litter (gC/(m**2 of ground)) / day
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)               :: bm_to_litter
+    ! veget_max
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                  :: veget_max
+    ! temperature (K) at the surface
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: tsurf
+    ! soil temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                      :: tsoil
+    ! daily soil humidity
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                      :: soilhum
+    ! daily litter humidity
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: litterhum
+
+    ! 0.2 modified fields
+
+    ! fraction of litter above the ground belonging to different PFTs
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)             :: litterpart
+    ! metabolic and structural litter,above and below ground (gC/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs), INTENT(inout)  :: litter
+    ! dead leaves on ground, per PFT, metabolic and structural,
+    !   in gC/(m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)             :: dead_leaves
+    ! ratio Lignine/Carbon in structural litter, above and below ground, (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)        :: lignin_struc
+
+    ! 0.3 output
+
+    ! fraction of soil covered by dead leaves
+    REAL(r_std), DIMENSION(npts), INTENT(out)                          :: deadleaf_cover
+    ! litter heterotrophic respiration (in gC/day/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                :: resp_hetero_litter
+    ! quantity of carbon going into carbon pools from litter decomposition
+    !   (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(out)          :: soilcarbon_input
+    ! temperature control of heterotrophic respiration, above and below
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(out)                    :: control_temp
+    ! moisture control of heterotrophic respiration
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(out)                    :: control_moist
+
+    ! 0.4 local
+
+    ! C/N ratio
+    REAL(r_std), SAVE, DIMENSION(nparts)                               :: CN
+    ! what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
+    REAL(r_std), SAVE, DIMENSION(nparts,nlitt)                         :: litterfrac
+    ! Lignine/C ratio of the different plant parts
+    REAL(r_std), SAVE, DIMENSION(nparts)                               :: LC
+    ! soil levels (m)
+    REAL(r_std), SAVE, DIMENSION(0:nbdl)                               :: z_soil
+    ! scaling depth for soil activity (m)
+    REAL(r_std), PARAMETER                                             :: z_decomp = 0.2
+    ! integration constant for vertical profiles
+    REAL(r_std), DIMENSION(npts)                                       :: rpc
+    ! residence time in litter pools (days)
+    REAL(r_std), SAVE, DIMENSION(nlitt)                                :: litter_tau
+    ! decomposition flux fraction that goes into soil (litter -> carbon, above and below)
+    !   rest goes into atmosphere
+    REAL(r_std), SAVE, DIMENSION(nlitt,ncarb,nlevs)                    :: frac_soil
+    ! temperature used for decompostition in soil (K)
+    REAL(r_std), DIMENSION(npts)                                       :: tsoil_decomp
+    ! humidity used for decompostition in soil
+    REAL(r_std), DIMENSION(npts)                                       :: soilhum_decomp
+    ! fraction of structural or metabolic litter decomposed
+    REAL(r_std), DIMENSION(npts)                                       :: fd
+    ! quantity of structural or metabolic litter decomposed (gC/m**2)
+    REAL(r_std), DIMENSION(npts)                                       :: qd
+    ! old structural litter, above and below (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                       :: old_struc
+    ! increase of litter, per PFT, metabolic and structural,
+    !   above and below ground (gC/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt,nlevs)                      :: litter_inc_PFT
+    ! increase of metabolic and structural litter, above and below ground (gC/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs)                 :: litter_inc
+    ! lignin increase in structural litter, above and below ground (gC/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nlevs)                       :: lignin_struc_inc
+    ! metabolic and structural litter above the ground per PFT
+    REAL(r_std), DIMENSION(npts,nvm,nlitt)                            :: litter_pft
+    ! intermediate array for looking for minimum
+    REAL(r_std), DIMENSION(npts)                                       :: zdiff_min
+    ! for messages
+    CHARACTER*10, DIMENSION(nlitt)                                    :: litter_str
+    CHARACTER*22, DIMENSION(nparts)                                   :: part_str
+    CHARACTER*7, DIMENSION(ncarb)                                     :: carbon_str
+    CHARACTER*5, DIMENSION(nlevs)                                     :: level_str
+    ! Indices
+    INTEGER(i_std)                                                    :: i,j,k,l,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering littercalc'
+
+    !
+    ! 1 Initialisations
+    !
+
+    IF ( firstcall ) THEN
+
+       !
+       ! 1.1 get soil "constants"
+       !
+
+       ! 1.1.1 C/N ratios
+
+       CN(ileaf) = 40.0
+       CN(isapabove) = 40.0
+       CN(isapbelow) = 40.0
+       CN(iheartabove) = 40.0
+       CN(iheartbelow) = 40.0
+       CN(iroot) = 40.0
+       CN(ifruit) = 40.0
+       CN(icarbres) = 40.0
+
+       ! 1.1.2 Lignine/C ratios
+
+       LC(ileaf) = 0.22
+       LC(isapabove) = 0.35
+       LC(isapbelow) = 0.35
+       LC(iheartabove) = 0.35
+       LC(iheartbelow) = 0.35
+       LC(iroot) = 0.22
+       LC(ifruit) = 0.22
+       LC(icarbres) = 0.22
+
+       ! 1.1.3 litter fractions:
+       !   what fraction of leaves, wood, etc. goes into metabolic and structural litterpools
+
+       DO k = 1, nparts
+
+          litterfrac(k,imetabolic) = 0.85 - 0.018 * LC(k) * CN(k)
+          litterfrac(k,istructural) = un - litterfrac(k,imetabolic)
+
+       ENDDO
+
+       ! 1.1.4 residence times in litter pools (days)
+
+       litter_tau(imetabolic) = .066 * one_year      !!!!???? .5 years
+       litter_tau(istructural) = .245 * one_year     !!!!???? 3 years
+
+       ! 1.1.5 decomposition flux fraction that goes into soil
+       !       (litter -> carbon, above and below)
+       !       1-frac_soil goes into atmosphere
+
+       frac_soil(:,:,:) = zero
+
+       ! structural litter: lignin fraction goes into slow pool + respiration,
+       !                    rest into active pool + respiration
+       frac_soil(istructural,iactive,iabove) = .55
+       frac_soil(istructural,iactive,ibelow) = .45
+       frac_soil(istructural,islow,iabove) = .7
+       frac_soil(istructural,islow,ibelow) = .7
+
+       ! metabolic litter: all goes into active pool + respiration.
+       !   Nothing into slow or passive pool.
+       frac_soil(imetabolic,iactive,iabove) = .45
+       frac_soil(imetabolic,iactive,ibelow) = .45
+
+       !
+       ! 1.2 soil levels
+       !
+
+       z_soil(0) = zero
+       z_soil(1:nbdl) = diaglev(1:nbdl)
+
+       !
+       ! 1.3 messages
+       !
+
+       litter_str(imetabolic) = 'metabolic'
+       litter_str(istructural) = 'structural'
+
+       carbon_str(iactive) = 'active'
+       carbon_str(islow) = 'slow'
+       carbon_str(ipassive) = 'passive'
+
+       level_str(iabove) = 'above'
+       level_str(ibelow) = 'below'
+
+       part_str(ileaf) = 'leaves'
+       part_str(isapabove) = 'sap above ground'
+       part_str(isapbelow) = 'sap below ground'
+       part_str(iheartabove) = 'heartwood above ground'
+       part_str(iheartbelow) = 'heartwood below ground'
+       part_str(iroot) = 'roots'
+       part_str(ifruit) = 'fruits'
+       part_str(icarbres) = 'carbohydrate reserve'
+
+       WRITE(numout,*) 'litter:'
+
+       WRITE(numout,*) '   > C/N ratios: '
+       DO k = 1, nparts
+          WRITE(numout,*) '       ', part_str(k), ': ',CN(k)
+       ENDDO
+
+       WRITE(numout,*) '   > Lignine/C ratios: '
+       DO k = 1, nparts
+          WRITE(numout,*) '       ', part_str(k), ': ',LC(k)
+       ENDDO
+
+       WRITE(numout,*) '   > fraction of compartment that goes into litter: '
+       DO k = 1, nparts
+          DO m = 1, nlitt
+             WRITE(numout,*) '       ', part_str(k), '-> ',litter_str(m), ':',litterfrac(k,m)
+          ENDDO
+       ENDDO
+
+       WRITE(numout,*) '   > scaling depth for decomposition (m): ',z_decomp
+
+       WRITE(numout,*) '   > minimal carbon residence time in litter pools (d):'
+       DO m = 1, nlitt
+          WRITE(numout,*) '       ',litter_str(m),':',litter_tau(m)
+       ENDDO
+
+       WRITE(numout,*) '   > litter decomposition flux fraction that really goes '
+       WRITE(numout,*) '     into carbon pools (rest into the atmosphere):'
+       DO m = 1, nlitt
+          DO l = 1, nlevs
+             DO k = 1, ncarb
+                WRITE(numout,*) '       ',litter_str(m),' ',level_str(l),' -> ',&
+                     carbon_str(k),':', frac_soil(m,k,l)
+             ENDDO
+          ENDDO
+       ENDDO
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.3 litter above the ground per PFT.
+    !
+
+    DO j = 2, nvm
+
+       DO k = 1, nlitt
+          litter_pft(:,j,k) = litterpart(:,j,k) * litter(:,k,j,iabove)
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 1.4 set output to zero
+    !
+
+    deadleaf_cover(:) = zero
+    resp_hetero_litter(:,:) = zero
+    soilcarbon_input(:,:,:) = zero
+
+    !
+    ! 2 Add biomass to different litterpools (per m**2 of ground)
+    !
+
+    !
+    ! 2.1 first, save old structural litter (needed for lignin fractions).
+    !     above/below
+    !
+
+    DO l = 1, nlevs
+       DO m = 2,nvm
+
+          old_struc(:,m,l) = litter(:,istructural,m,l)
+
+       ENDDO
+    ENDDO
+
+    !
+    ! 2.2 update litter, dead leaves, and lignin content in structural litter
+    !
+
+    litter_inc(:,:,:,:) = zero
+    lignin_struc_inc(:,:,:) = zero
+
+    DO j = 2,nvm
+
+       ! 2.2.1 litter
+
+       DO k = 1, nlitt    ! metabolic and structural
+
+          ! 2.2.2 calculate litter increase (per m**2 of ground).
+          !       Only a given fracion of fruit turnover is directly coverted into litter.
+          !       Litter increase for each PFT, structural and metabolic, above/below
+
+          litter_inc_PFT(:,j,k,iabove) = &
+               litterfrac(ileaf,k) * bm_to_litter(:,j,ileaf) + &
+               litterfrac(isapabove,k) * bm_to_litter(:,j,isapabove) + &
+               litterfrac(iheartabove,k) * bm_to_litter(:,j,iheartabove) + &
+               litterfrac(ifruit,k) * bm_to_litter(:,j,ifruit) + &
+               litterfrac(icarbres,k) * bm_to_litter(:,j,icarbres) + &
+               litterfrac(ileaf,k) * turnover(:,j,ileaf) + &
+               litterfrac(isapabove,k) * turnover(:,j,isapabove) + &
+               litterfrac(iheartabove,k) * turnover(:,j,iheartabove) + &
+               litterfrac(ifruit,k) * turnover(:,j,ifruit) + &
+               litterfrac(icarbres,k) * turnover(:,j,icarbres)
+
+          litter_inc_PFT(:,j,k,ibelow) = &
+               litterfrac(isapbelow,k) * bm_to_litter(:,j,isapbelow) + &
+               litterfrac(iheartbelow,k) * bm_to_litter(:,j,iheartbelow) + &
+               litterfrac(iroot,k) * bm_to_litter(:,j,iroot) + &
+               litterfrac(isapbelow,k) * turnover(:,j,isapbelow) + &
+               litterfrac(iheartbelow,k) * turnover(:,j,iheartbelow) + &
+               litterfrac(iroot,k) * turnover(:,j,iroot)
+
+          ! litter increase, met/struct, above/below
+
+          litter_inc(:,k,j,iabove) = litter_inc(:,k,j,iabove) + litter_inc_PFT(:,j,k,iabove)
+          litter_inc(:,k,j,ibelow) = litter_inc(:,k,j,ibelow) + litter_inc_PFT(:,j,k,ibelow)
+
+          ! 2.2.3 dead leaves, for soil cover.
+
+          dead_leaves(:,j,k) = &
+               dead_leaves(:,j,k) + &
+               litterfrac(ileaf,k) * ( bm_to_litter(:,j,ileaf) + turnover(:,j,ileaf) )
+
+          ! 2.2.4 lignin increase in structural litter
+
+          IF ( k .EQ. istructural ) THEN
+
+             lignin_struc_inc(:,j,iabove) = &
+                  lignin_struc_inc(:,j,iabove) + &
+                  LC(ileaf) * bm_to_litter(:,j,ileaf) + &
+                  LC(isapabove) * bm_to_litter(:,j,isapabove) + &
+                  LC(iheartabove) * bm_to_litter(:,j,iheartabove) + &
+                  LC(ifruit) * bm_to_litter(:,j,ifruit) + &
+                  LC(icarbres) * bm_to_litter(:,j,icarbres) + &
+                  LC(ileaf) * turnover(:,j,ileaf) + &
+                  LC(isapabove) * turnover(:,j,isapabove) + &
+                  LC(iheartabove) * turnover(:,j,iheartabove) + &
+                  LC(ifruit) * turnover(:,j,ifruit) + &
+                  LC(icarbres) * turnover(:,j,icarbres)
+
+             lignin_struc_inc(:,j,ibelow) = &
+                  lignin_struc_inc(:,j,ibelow) + &
+                  LC(isapbelow) * bm_to_litter(:,j,isapbelow) + &
+                  LC(iheartbelow) * bm_to_litter(:,j,iheartbelow) + &
+                  LC(iroot) * bm_to_litter(:,j,iroot) + &
+                  LC(isapbelow)*turnover(:,j,isapbelow) + &
+                  LC(iheartbelow)*turnover(:,j,iheartbelow) + &
+                  LC(iroot)*turnover(:,j,iroot)
+
+          ENDIF
+
+       ENDDO
+    ENDDO
+
+    ! 3.2.5 add new litter (struct/met, above/below)
+
+    litter(:,:,:,:) = litter(:,:,:,:) + litter_inc(:,:,:,:)
+
+    ! 3.2.6 for security: can't add more lignin than structural litter (above/below)
+
+    DO l = 1, nlevs
+       DO m = 2,nvm
+
+          lignin_struc_inc(:,m,l) = &
+               MIN( lignin_struc_inc(:,m,l), litter_inc(:,istructural,m,l) )
+
+       ENDDO
+    ENDDO
+
+    ! 3.2.7 new lignin content: add old lignin and lignin increase, divide by 
+    !       total structural litter (above/below)
+
+    DO l = 1, nlevs
+       DO m = 2,nvm
+          WHERE( litter(:,istructural,m,l) .GT. min_stomate )
+
+       !MM : Soenke modif
+       ! Best vectorization ?
+!!$       lignin_struc(:,:,:) = &
+!!$            ( lignin_struc(:,:,:)*old_struc(:,:,:) + lignin_struc_inc(:,:,:) ) / &
+!!$            litter(:,istructural,:,:,icarbon)
+
+             lignin_struc(:,m,l) = lignin_struc(:,m,l) * old_struc(:,m,l)
+             lignin_struc(:,m,l) = lignin_struc(:,m,l) + lignin_struc_inc(:,m,l)
+             lignin_struc(:,m,l) = lignin_struc(:,m,l) / litter(:,istructural,m,l)
+          ELSEWHERE
+             lignin_struc(:,m,l) = zero
+          ENDWHERE
+       ENDDO
+    ENDDO
+
+    !
+    ! 3.3 new litter fraction per PFT (for structural and metabolic litter, above
+    !       the ground).
+    !
+
+    DO j = 2,nvm
+
+       WHERE ( litter(:,:,j,iabove) .GT. min_stomate )
+
+          litterpart(:,j,:) = &
+               ( litter_pft(:,j,:) + litter_inc_PFT(:,j,:,iabove) ) / litter(:,:,j,iabove)
+
+       ELSEWHERE
+
+          litterpart(:,j,:) = zero
+
+       ENDWHERE
+
+    ENDDO
+
+    !
+    ! 4 Temperature control on decay: Factor between 0 and 1
+    !
+
+    !
+    ! 4.1 above: surface temperature
+    !
+
+    control_temp(:,iabove) = control_temp_func (npts, tsurf)
+
+    !
+    ! 4.2 below: convolution of temperature and decomposer profiles
+    !            (exponential decomposer profile supposed)
+    !
+
+    ! 4.2.1 rpc is an integration constant such that the integral of the root profile is 1.
+    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_decomp ) )
+
+    ! 4.2.2 integrate over the nbdl levels
+
+    tsoil_decomp(:) = 0.0
+
+    DO l = 1, nbdl
+
+       tsoil_decomp(:) = &
+            tsoil_decomp(:) + tsoil(:,l) * rpc(:) * &
+            ( EXP( -z_soil(l-1)/z_decomp ) - EXP( -z_soil(l)/z_decomp ) )
+
+    ENDDO
+
+    control_temp(:,ibelow) = control_temp_func (npts, tsoil_decomp)
+
+    !
+    ! 5 Moisture control. Factor between 0 and 1
+    !
+
+    !
+    ! 5.1 above the ground: litter humidity
+    !
+
+    control_moist(:,iabove) = control_moist_func (npts, litterhum)
+
+    !
+    ! 5.2 below: convolution of humidity and decomposer profiles
+    !            (exponential decomposer profile supposed)
+    !
+
+    ! 5.2.1 rpc is an integration constant such that the integral of the root profile is 1.
+    rpc(:) = un / ( un - EXP( -z_soil(nbdl) / z_decomp ) )
+
+    ! 5.2.2 integrate over the nbdl levels
+
+    soilhum_decomp(:) = 0.0
+
+    DO l = 1, nbdl
+
+       soilhum_decomp(:) = &
+            soilhum_decomp(:) + soilhum(:,l) * rpc(:) * &
+            ( EXP( -z_soil(l-1)/z_decomp ) - EXP( -z_soil(l)/z_decomp ) )
+
+    ENDDO
+
+    control_moist(:,ibelow) = control_moist_func (npts, soilhum_decomp)
+
+    !
+    ! 6 fluxes from litter to carbon pools and respiration
+    !
+
+    DO l = 1, nlevs
+       DO m = 2,nvm
+
+          !
+          ! 6.1 structural litter: goes into active and slow carbon pools + respiration
+          !
+
+          ! 6.1.1 total quantity of structural litter which is decomposed
+
+          fd(:) = dt/litter_tau(istructural) * &
+               control_temp(:,l) * control_moist(:,l) * exp( -3. * lignin_struc(:,m,l) )
+
+          qd(:) = litter(:,istructural,m,l) * fd(:)
+
+          litter(:,istructural,m,l) = litter(:,istructural,m,l) - qd(:)
+
+          ! 6.1.2 decompose same fraction of structural part of dead leaves. Not exact
+          !       as lignine content is not the same as that of the total structural litter.
+
+          ! to avoid a multiple (for ibelow and iabove) modification of dead_leaves,
+          ! we do this test to do this calcul only ones in 1,nlev loop
+          if (l == iabove)  dead_leaves(:,m,istructural) = dead_leaves(:,m,istructural) * ( un - fd(:) )
+
+          ! 6.1.3 non-lignin fraction of structural litter goes into
+          !       active carbon pool + respiration
+
+          soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
+               frac_soil(istructural,iactive,l) * qd(:) * ( 1. - lignin_struc(:,m,l) ) / dt
+
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,iactive,l) ) * qd(:) * &
+               ( 1. - lignin_struc(:,m,l) ) / dt
+
+          ! 6.1.4 lignin fraction of structural litter goes into
+          !       slow carbon pool + respiration
+
+          soilcarbon_input(:,islow,m) = soilcarbon_input(:,islow,m) + &
+               frac_soil(istructural,islow,l) * qd(:) * lignin_struc(:,m,l) / dt
+
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(istructural,islow,l) ) * qd(:) * lignin_struc(:,m,l) / dt
+
+          !
+          ! 6.2 metabolic litter goes into active carbon pool + respiration
+          !
+
+          ! 6.2.1 total quantity of metabolic litter that is decomposed
+
+          fd(:) = dt/litter_tau(imetabolic) * control_temp(:,l) * control_moist(:,l)
+
+          qd(:) = litter(:,imetabolic,m,l) * fd(:)
+
+          litter(:,imetabolic,m,l) = litter(:,imetabolic,m,l) - qd(:)
+
+          ! 6.2.2 decompose same fraction of metabolic part of dead leaves.
+
+          ! to avoid a multiple (for ibelow and iabove) modification of dead_leaves,
+          ! we do this test to do this calcul only ones in 1,nlev loop
+          if (l == iabove)  dead_leaves(:,m,imetabolic) = dead_leaves(:,m,imetabolic) * ( 1. - fd(:) )
+
+
+          ! 6.2.3 put decomposed litter into carbon pool + respiration
+
+          soilcarbon_input(:,iactive,m) = soilcarbon_input(:,iactive,m) + &
+               frac_soil(imetabolic,iactive,l) * qd(:) / dt
+
+          resp_hetero_litter(:,m) = resp_hetero_litter(:,m) + &
+               ( 1. - frac_soil(imetabolic,iactive,l) ) * qd(:) / dt
+
+       ENDDO
+    ENDDO
+
+    !
+    ! 7 calculate fraction of total soil covered by dead leaves
+    !
+
+    CALL deadleaf (npts, veget_max, dead_leaves, deadleaf_cover)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving littercalc'
+
+  END SUBROUTINE littercalc
+
+  SUBROUTINE deadleaf (npts, veget_max, dead_leaves, deadleaf_cover)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                               :: npts
+    ! dead leaves on ground, per PFT, metabolic and structural,
+    !   in gC/(m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(in)                :: dead_leaves
+    !veget_max
+    REAL(r_std),DIMENSION(npts,nvm),INTENT(in)                 :: veget_max
+    ! 0.2. output
+    ! fraction of soil covered by dead leaves
+    REAL(r_std), DIMENSION(npts), INTENT(out)                          :: deadleaf_cover
+
+    ! 0.3. local
+
+    ! LAI of dead leaves
+    REAL(r_std), DIMENSION(npts)                                       :: dead_lai
+    ! Index
+    INTEGER(i_std)                                                    :: j
+
+    !
+    ! 1 LAI of dead leaves
+    !
+
+    dead_lai(:) = zero
+
+    DO j = 2,nvm
+       dead_lai(:) = dead_lai(:) + ( dead_leaves(:,j,imetabolic) + dead_leaves(:,j,istructural) ) * sla(j) &
+            * veget_max(:,j)
+    ENDDO
+
+    !
+    ! 2 fraction of soil covered by dead leaves
+    !
+
+    deadleaf_cover(:) = 1. - exp( - 0.5 * dead_lai(:) )
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving deadleaf'
+
+  END SUBROUTINE deadleaf
+
+  FUNCTION control_moist_func (npts, moist_in) RESULT (moistfunc_result)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                               :: npts
+    ! relative humidity
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: moist_in
+
+    ! 0.2 result
+
+    ! moisture control factor
+    REAL(r_std), DIMENSION(npts)                                       :: moistfunc_result
+
+    moistfunc_result(:) = -1.1 * moist_in(:) * moist_in(:) + 2.4 * moist_in(:) - 0.29
+    moistfunc_result(:) = MAX( 0.25_r_std, MIN( 1._r_std, moistfunc_result(:) ) )
+
+  END FUNCTION control_moist_func
+
+  FUNCTION control_temp_func (npts, temp_in) RESULT (tempfunc_result)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                               :: npts
+    ! temperature (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: temp_in
+
+    ! 0.2 result
+
+    ! temperature control factor
+    REAL(r_std), DIMENSION(npts)                                       :: tempfunc_result
+
+    tempfunc_result(:) = exp( 0.69 * ( temp_in(:) - (ZeroCelsius+30.) ) / 10. )
+    tempfunc_result(:) = MIN( 1._r_std, tempfunc_result(:) )
+
+  END FUNCTION control_temp_func
+
+END MODULE stomate_litter
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_lpj.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_lpj.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_lpj.f90	(revision 55)
@@ -0,0 +1,1022 @@
+! Stomate: phenology, allocation, etc.
+!
+! authors: A. Botta, P. Friedlingstein, C. Morphopoulos, N. Viovy, et al.
+!
+! bits and pieces put together by G. Krinner
+!
+! version 0.0: August 1998
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_lpj.f90,v 1.26 2010/08/05 16:02:37 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_lpj
+
+  ! modules used:
+
+  USE ioipsl
+  USE grid
+  USE stomate_constants
+  USE lpj_constraints
+  USE lpj_pftinout
+  USE lpj_kill
+  USE lpj_crown
+  USE lpj_fire
+  USE lpj_gap
+  USE lpj_light
+  USE lpj_establish
+  USE lpj_cover
+  USE stomate_prescribe
+  USE stomate_phenology
+  USE stomate_alloc
+  USE stomate_npp
+  USE stomate_turnover
+  USE stomate_litter
+  USE stomate_soilcarbon
+  USE stomate_vmax
+  USE stomate_assimtemp
+  USE constantes_veg
+  USE stomate_lcchange
+  !  USE Write_Field_p
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC StomateLpj,StomateLpj_clear
+
+  ! first call
+  LOGICAL, SAVE                                           :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE StomateLpj_clear
+
+    CALL prescribe_clear
+    CALL phenology_clear
+    CALL npp_calc_clear
+    CALL turn_clear
+    CALL soilcarbon_clear
+    CALL constraints_clear
+    CALL establish_clear
+    CALL fire_clear
+    CALL gap_clear
+    CALL light_clear
+    CALL pftinout_clear
+    CALL alloc_clear
+  END SUBROUTINE StomateLpj_clear
+
+  SUBROUTINE StomateLpj (npts, dt_days, EndOfYear, EndOfMonth, &
+       neighbours, resolution, &
+       clay, herbivores, &
+       tsurf_daily, tsoil_daily, t2m_daily, t2m_min_daily, &
+       litterhum_daily, soilhum_daily, &
+       maxmoiavail_lastyear, minmoiavail_lastyear, &
+       gdd0_lastyear, precip_lastyear, &
+       moiavail_month, moiavail_week, tlong_ref, t2m_month, t2m_week, &
+       tsoil_month, soilhum_month, &
+       gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+       turnover_longterm, gpp_daily, time_lowgpp, &
+       time_hum_min, maxfpc_lastyear, resp_maint_part, &
+       PFTpresent, age, fireindex, firelitter, &
+       leaf_age, leaf_frac, biomass, ind, adapted, regenerate, &
+       senescence, when_growthinit, &
+       litterpart, litter, dead_leaves, carbon, black_carbon, lignin_struc, &
+       veget_max, veget, npp_longterm, lm_lastyearmax, veget_lastlight, &
+       everywhere, need_adjacent, RIP_time, &
+       lai, rprof,npp_daily, turnover_daily, turnover_time,&
+       control_moist, control_temp, soilcarbon_input, &
+       co2_to_bm, co2_fire, resp_hetero, resp_maint, resp_growth, &
+       height, deadleaf_cover, vcmax, vjmax, &
+       t_photo_min, t_photo_opt, t_photo_max,bm_to_litter, &
+       prod10,prod100,flux10, flux100, veget_max_new, &
+       convflux,cflux_prod10,cflux_prod100, harvest_above, lcchange)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                           :: npts
+    ! time step of Stomate in days
+    REAL(r_std), INTENT(in)                                        :: dt_days
+    ! indices of the 8 neighbours of each grid point (1=N, 2=NE, 3=E, 4=SE, 5=S, 6=SW, 7=W, 8=NW)
+    INTEGER(i_std), DIMENSION(npts,8), INTENT(in)                 :: neighbours
+    ! resolution at each grid point in m (1=E-W, 2=N-S)
+    REAL(r_std), DIMENSION(npts,2), INTENT(in)                     :: resolution
+    ! clay fraction
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: clay
+    ! time constant of probability of a leaf to be eaten by a herbivore (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: herbivores
+    ! daily surface temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: tsurf_daily
+    ! daily soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                  :: tsoil_daily
+    ! daily 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: t2m_daily
+    ! daily minimum 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: t2m_min_daily
+    ! daily litter humidity
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: litterhum_daily
+    ! daily soil humidity
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                  :: soilhum_daily
+    ! last year's maximum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: maxmoiavail_lastyear
+    ! last year's minimum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: minmoiavail_lastyear
+    ! last year's GDD0
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: gdd0_lastyear
+    ! lastyear's precipitation (mm/year)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: precip_lastyear
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: moiavail_month
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: moiavail_week
+    ! "long term" 2 meter reference temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: tlong_ref
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: t2m_month
+    ! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                       :: t2m_week
+    ! "monthly" soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                  :: tsoil_month
+    ! "monthly" soil humidity
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)                  :: soilhum_month
+    ! growing degree days, threshold -5 deg C (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                   :: gdd_m5_dormance
+    ! growing degree days, since midwinter (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                   :: gdd_midwinter
+    ! number of chilling days, since leaves were lost (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: ncd_dormance
+    ! number of growing days, threshold -5 deg C (for phenology)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: ngd_minus5
+    ! "long term" turnover rate (gC/(m**2 of ground)/year)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)           :: turnover_longterm
+    ! daily gross primary productivity (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: gpp_daily
+    ! duration of dormance (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: time_lowgpp
+    ! time elapsed since strongest moisture availability (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: time_hum_min
+    ! last year's maximum fpc for each natural PFT, on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                  :: maxfpc_lastyear
+    ! maintenance respiration of different plant parts (gC/day/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)             :: resp_maint_part
+
+    ! 0.2 modified fields
+
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)                  :: PFTpresent
+    ! age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: age
+    ! Probability of fire
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: fireindex
+    ! Longer term litter above the ground, gC/m**2 of ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: firelitter
+    ! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)     :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)     :: leaf_frac
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)        :: biomass
+    ! density of individuals (1/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: ind
+    ! Winter too cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: adapted
+    ! Winter sufficiently cold? between 0 and 1
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: regenerate
+    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)                  :: senescence
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: when_growthinit
+    ! fraction of litter above the ground belonging to different PFTs
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)         :: litterpart
+    ! metabolic and structural litter, above and below ground (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nlitt,nvm,nlevs), INTENT(inout)  :: litter
+    ! dead leaves on ground, per PFT, metabolic and structural, 
+    !   in gC/(m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nlitt), INTENT(inout)         :: dead_leaves
+    ! carbon pool: active, slow, or passive,(gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(inout)    :: carbon
+    ! black carbon on the ground (gC/(m**2 of total ground))
+    REAL(r_std), DIMENSION(npts), INTENT(inout)                    :: black_carbon
+    ! ratio Lignine/Carbon in structural litter, above and below ground,
+    ! (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nlevs), INTENT(inout)    :: lignin_struc
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: veget_max
+    ! fractional coverage on ground, taking into account LAI (=grid-scale fpc)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: veget
+    ! "long term" net primary productivity (gC/(m**2 of ground)/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: npp_longterm
+    ! last year's maximum leaf mass, for each PFT (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: lm_lastyearmax
+    ! vegetation fractions (on ground) after last light competition
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: veget_lastlight
+    ! is the PFT everywhere in the grid box or very localized (after its introduction)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: everywhere
+    ! in order for this PFT to be introduced, does it have to be present in an
+    !   adjacent grid box?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)                  :: need_adjacent
+    ! How much time ago was the PFT eliminated for the last time (y)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: RIP_time
+    ! Turnover_time of leaves for grasses (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)          :: turnover_time
+
+    ! 0.3 output
+
+    ! leaf area index OF AN INDIVIDUAL PLANT
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: lai
+    ! root depth. This will, one day, be a prognostic variable. It will be calculated by
+    ! STOMATE (save in restart file & give to hydrology module!), probably somewhere
+    ! in the allocation routine. For the moment, it is prescribed.
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: rprof
+    ! net primary productivity (gC/day/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: npp_daily
+    ! Turnover rates (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)          :: turnover_daily
+    ! moisture control of heterotrophic respiration
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(inout)                :: control_moist
+    ! temperature control of heterotrophic respiration, above and below
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(inout)                :: control_temp
+    ! quantity of carbon going into carbon pools from litter decomposition
+    !   (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(inout)      :: soilcarbon_input
+    ! co2 taken up (gC/(m**2 of total ground)/day)
+    !NV devient 2D
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                      :: co2_to_bm
+    ! carbon emitted into the atmosphere by fire (living and dead biomass)
+    ! (in gC/m**2 of total ground/day)
+    !NV devient 2D
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                      :: co2_fire
+    ! heterotrophic respiration (gC/day/m**2 of total ground)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: resp_hetero
+    ! maintenance respiration (gC/day/(m**2 of total ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: resp_maint
+    ! growth respiration (gC/day/(m**2 of total ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: resp_growth
+    ! height of vegetation (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: height
+    ! fraction of soil covered by dead leaves
+    REAL(r_std), DIMENSION(npts), INTENT(inout)                      :: deadleaf_cover
+    ! Maximum rate of carboxylation
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: vcmax
+    ! Maximum rate of RUbp regeneration
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: vjmax
+    ! Minimum temperature for photosynthesis (deg C)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: t_photo_min
+    ! Optimum temperature for photosynthesis (deg C)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: t_photo_opt
+    ! Maximum temperature for photosynthesis (deg C)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                 :: t_photo_max
+    ! conversion of biomass to litter (gC/(m**2 of ground)) / day
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)          :: bm_to_litter
+    !
+    ! new "maximal" coverage fraction of a PFT (LAI -> infinity)
+    REAL(r_std), DIMENSION(npts,nvm),INTENT(inout)                 :: veget_max_new 
+
+    ! products remaining in the 10/100 year-turnover pool after the annual release for each compartment
+    ! (10 or 100 + 1 : input from year of land cover change)
+    REAL(r_std),DIMENSION(npts,0:10), INTENT(inout)                        :: prod10
+    REAL(r_std),DIMENSION(npts,0:100), INTENT(inout)                       :: prod100
+    ! annual release from the 10/100 year-turnover pool compartments
+    REAL(r_std),DIMENSION(npts,10), INTENT(inout)                       :: flux10
+    REAL(r_std),DIMENSION(npts,100), INTENT(inout)                      :: flux100
+    ! release during first year following land cover change
+    REAL(r_std),DIMENSION(npts), INTENT(inout)                          :: convflux
+    ! total annual release from the 10/100 year-turnover pool
+    REAL(r_std),DIMENSION(npts), INTENT(inout)                          :: cflux_prod10, cflux_prod100
+    ! harvest above ground biomass for agriculture
+    REAL(r_std), DIMENSION(npts), INTENT(inout)                       :: harvest_above
+
+    ! land cover change flag
+    LOGICAL, INTENT(in)                                                :: lcchange
+
+    ! Land cover change variables + EndOfYear
+    ! Do update of yearly variables? This variable must be .TRUE. once a year
+    LOGICAL, INTENT(in)                                                :: EndOfYear
+    ! Do update of monthly variables ? This variable must be .TRUE. once a month
+    LOGICAL, INTENT(in)                                                :: EndOfMonth
+
+
+    ! 0.4 local
+
+    ! total conversion of biomass to litter (gC/(m**2)) / day
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: tot_bm_to_litter
+    ! total living biomass (gC/(m**2)) 
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: tot_live_biomass
+    ! biomass increase, i.e. NPP per plant part
+    REAL(r_std), DIMENSION(npts,nvm,nparts)                            :: bm_alloc
+    ! total turnover rate (gC/(m**2)) / day
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: tot_turnover
+    ! total soil and litter carbon (gC/(m**2))
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: tot_litter_soil_carb
+    ! total litter carbon (gC/(m**2))
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: tot_litter_carb
+    ! total soil carbon (gC/(m**2))
+    REAL(r_std), DIMENSION(npts,nvm)                                   :: tot_soil_carb
+    ! crown area of individuals (m**2)
+    REAL(r_std), DIMENSION(npts,nvm)                               :: cn_ind
+    ! fraction that goes into plant part
+    REAL(r_std), DIMENSION(npts,nvm,nparts)                        :: f_alloc
+    ! space availability for trees
+    REAL(r_std), DIMENSION(npts)                                   :: avail_tree
+    ! space availability for grasses
+    REAL(r_std), DIMENSION(npts)                                   :: avail_grass
+
+    INTEGER                                                       :: j
+
+    ! total products remaining in the pool after the annual release 
+    REAL(r_std),DIMENSION(npts)                                   :: prod10_total, prod100_total 
+    ! total flux from conflux and the 10/100 year-turnover pool 
+    REAL(r_std),DIMENSION(npts)                                       :: cflux_prod_total
+    ! total land cover fluxes
+    REAL(r_std)                                                       :: cflux_prod_total_sum,cflux_prod_sum
+
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std),DIMENSION(npts,nvm)                                :: veget_max_old
+
+    REAL(r_std), DIMENSION(npts)                                   :: vartmp
+
+    REAL(r_std), DIMENSION(npts,nvm)                          :: histvar
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering stomate_lpj'
+
+    !
+    ! 1 Initializations
+    !
+
+    !
+    ! 1.1 set outputs to zero
+    !
+    co2_to_bm(:,:) = zero
+    co2_fire(:,:) = zero
+    npp_daily(:,:) = zero
+    turnover_daily(:,:,:) = zero
+    resp_maint(:,:) = zero
+    resp_growth(:,:) = zero
+    harvest_above(:) = zero
+
+    !
+    ! 1.2  initialize some variables
+    !
+
+    bm_to_litter(:,:,:) = zero
+    cn_ind(:,:) = zero
+    veget_max_old(:,:) = veget_max(:,:)
+
+    !
+    ! 1.3 Prescribe some vegetation characteristics if the vegetation is not dynamic
+    !     IF the DGVM is not activated, the density of individuals and their crown
+    !     areas don't matter, but they should be defined for the case we switch on
+    !     the DGVM afterwards.
+    !     At first call, if the DGVM is not activated, impose a minimum biomass for 
+    !       prescribed PFTs and declare them present.
+    !
+
+    CALL prescribe (npts, &
+         veget_max, PFTpresent, everywhere, when_growthinit, &
+         biomass, leaf_frac, ind, cn_ind)
+
+    !
+    ! 2 climatic constraints for PFT presence and regenerativeness
+    !   call this even when DGVM is not activated so that "adapted" and "regenerate"
+    !   are kept up to date for the moment when the DGVM is activated.
+    !
+
+    CALL constraints (npts, dt_days, &
+         t2m_month, t2m_min_daily, when_growthinit, &
+         adapted, regenerate)
+
+    !
+    ! 3 PFTs in and out, based on climate criteria
+    !
+
+    IF ( control%ok_dgvm ) THEN
+
+       !
+       ! 3.1 do introduction/elimination
+       !
+
+       CALL pftinout (npts, dt_days, adapted, regenerate, &
+            neighbours, veget, veget_max, &
+            biomass, ind, age, leaf_frac, npp_longterm, lm_lastyearmax, senescence, &
+            PFTpresent, everywhere, when_growthinit, need_adjacent, RIP_time, &
+            co2_to_bm, &
+            avail_tree, avail_grass)
+
+       !
+       ! 3.2 reset attributes for eliminated PFTs.
+       !     This also kills PFTs that had 0 leafmass during the last year. The message
+       !     "... after pftinout" is misleading in this case.
+       !
+
+       CALL kill (npts, 'pftinout  ', lm_lastyearmax, &
+            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+            lai, age, leaf_age, leaf_frac, &
+            when_growthinit, everywhere, veget, veget_max, bm_to_litter)
+
+       !
+       ! 3.3 calculate new crown area and maximum vegetation cover
+       !
+
+       CALL crown (npts, PFTpresent, &
+            ind, biomass, &
+            veget_max, cn_ind, height)
+
+    ENDIF
+
+    !
+    ! 4 phenology
+    !
+    CALL histwrite (hist_id_stomate, 'WHEN_GROWTHINIT', itime, when_growthinit, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'TIME_LOWGPP', itime, time_lowgpp, npts*nvm, horipft_index)
+
+    WHERE(PFTpresent)
+       histvar=un
+    ELSEWHERE
+       histvar=zero
+    ENDWHERE
+    CALL histwrite (hist_id_stomate, 'PFTPRESENT', itime, histvar, npts*nvm, horipft_index)
+
+    WHERE(gdd_midwinter.EQ.undef)
+       histvar=val_exp
+    ELSEWHERE
+       histvar=gdd_midwinter
+    ENDWHERE
+    CALL histwrite (hist_id_stomate, 'GDD_MIDWINTER', itime, histvar, npts*nvm, horipft_index)
+
+    WHERE(ncd_dormance.EQ.undef)
+       histvar=val_exp
+    ELSEWHERE
+       histvar=ncd_dormance
+    ENDWHERE
+    CALL histwrite (hist_id_stomate, 'NCD_DORMANCE', itime, histvar, npts*nvm, horipft_index)
+
+    CALL phenology (npts, dt_days, PFTpresent, &
+         veget_max, &
+         tlong_ref, t2m_month, t2m_week, gpp_daily, &
+         maxmoiavail_lastyear, minmoiavail_lastyear, &
+         moiavail_month, moiavail_week, &
+         gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+         senescence, time_lowgpp, time_hum_min, &
+         biomass, leaf_frac, leaf_age, &
+         when_growthinit, co2_to_bm, lai)
+
+    !
+    ! 5 allocation
+    !
+
+    CALL alloc (npts, dt_days, &
+         lai, veget_max, senescence, when_growthinit, &
+         moiavail_week, tsoil_month, soilhum_month, &
+         biomass, age, leaf_age, leaf_frac, rprof, f_alloc)
+
+    !
+    ! 6 maintenance and growth respiration. NPP
+    !
+
+    CALL npp_calc (npts, dt_days, &
+         PFTpresent, &
+         tlong_ref, t2m_daily, tsoil_daily, lai, rprof, &
+         gpp_daily, f_alloc, bm_alloc, resp_maint_part,&
+         biomass, leaf_age, leaf_frac, age, &
+         resp_maint, resp_growth, npp_daily)
+
+    IF ( control%ok_dgvm ) THEN
+
+       ! new provisional crown area and maximum vegetation cover after growth
+
+       CALL crown (npts, PFTpresent, &
+            ind, biomass, &
+            veget_max, cn_ind, height)
+
+    ENDIF
+
+    !
+    ! 7 fire.
+    !
+
+    CALL fire (npts, dt_days, litterpart, &
+         litterhum_daily, t2m_daily, lignin_struc, &
+         fireindex, firelitter, biomass, ind, &
+         litter, dead_leaves, bm_to_litter, black_carbon, &
+         co2_fire)
+
+    IF ( control%ok_dgvm ) THEN
+
+       ! reset attributes for eliminated PFTs
+
+       CALL kill (npts, 'fire      ', lm_lastyearmax, &
+            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+            lai, age, leaf_age, leaf_frac, &
+            when_growthinit, everywhere, veget, veget_max, bm_to_litter)
+
+    ENDIF
+
+    !
+    ! 8 tree mortality. Does not depend on age, therefore does not change crown area.
+    !
+
+    CALL gap (npts, dt_days, &
+         npp_longterm, turnover_longterm, lm_lastyearmax, &
+         PFTpresent, biomass, ind, bm_to_litter)
+
+    IF ( control%ok_dgvm ) THEN
+
+       ! reset attributes for eliminated PFTs
+
+       CALL kill (npts, 'gap       ', lm_lastyearmax, &
+            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+            lai, age, leaf_age, leaf_frac, &
+            when_growthinit, everywhere, veget, veget_max, bm_to_litter)
+
+    ENDIF
+
+    !
+    ! 9 calculate vcmax, vjmax and photosynthesis temperatures
+    !
+
+    CALL vmax (npts, dt_days, &
+         leaf_age, leaf_frac, &
+         vcmax, vjmax)
+
+    CALL assim_temp (npts, tlong_ref, t2m_month, &
+         t_photo_min, t_photo_opt, t_photo_max)
+
+    !
+    ! 10 leaf senescence and other turnover processes. New lai
+    !
+
+    CALL turn (npts, dt_days, PFTpresent, &
+         herbivores, &
+         maxmoiavail_lastyear, minmoiavail_lastyear, &
+         moiavail_week,  moiavail_month,tlong_ref, t2m_month, t2m_week, veget_max, &
+         leaf_age, leaf_frac, age, lai, biomass, &
+         turnover_daily, senescence,turnover_time)
+
+    !
+    ! 11 light competition
+    !
+
+    IF ( control%ok_dgvm ) THEN
+
+       !
+       ! 11.1 do light competition
+       !
+
+       CALL light (npts, dt_days, &
+            PFTpresent, cn_ind, lai, maxfpc_lastyear, &
+            ind, biomass, veget_lastlight, bm_to_litter)
+
+       !
+       ! 11.2 reset attributes for eliminated PFTs
+       !
+
+       CALL kill (npts, 'light     ', lm_lastyearmax, &
+            ind, PFTpresent, cn_ind, biomass, senescence, RIP_time, &
+            lai, age, leaf_age, leaf_frac, &
+            when_growthinit, everywhere, veget, veget_max, bm_to_litter)
+
+    ENDIF
+
+    !
+    ! 12 establishment of saplings
+    !
+
+    IF ( control%ok_dgvm ) THEN
+
+       !
+       ! 12.1 do establishment
+       !
+
+       CALL establish (npts, dt_days, PFTpresent, regenerate, &
+            neighbours, resolution, need_adjacent, herbivores, &
+            precip_lastyear, gdd0_lastyear, lm_lastyearmax, &
+            cn_ind, lai, avail_tree, avail_grass, &
+            leaf_age, leaf_frac, &
+            ind, biomass, age, everywhere, co2_to_bm, veget_max)
+
+       !
+       ! 12.2 calculate new crown area (and maximum vegetation cover)
+       !
+
+       CALL crown (npts, PFTpresent, &
+            ind, biomass, &
+            veget_max, cn_ind, height)
+
+    ENDIF
+
+    !
+    ! 13 calculate final LAI and vegetation cover.
+    !
+
+    CALL cover (npts, cn_ind, ind, biomass, &
+         veget_max, veget_max_old, veget, &
+         lai, litter, carbon)
+
+    !
+    ! 14 the whole litter stuff:
+    !    litter update, lignin content, PFT parts, litter decay, 
+    !    litter heterotrophic respiration, dead leaf soil cover.
+    !    No vertical discretisation in the soil for litter decay.
+    !
+    ! added by shilong for harvest
+    IF(harvest_agri) THEN
+       CALL harvest(npts, dt_days, veget_max, veget, &
+            bm_to_litter, turnover_daily, &
+            harvest_above)
+    ENDIF
+
+    ! 15.1  Land cover change
+
+    !shilong adde turnover_daily
+    IF(EndOfYear) THEN
+       IF (lcchange) THEN
+          CALL lcchange_main (npts, dt_days, veget_max, veget_max_new, &
+               biomass, ind, age, PFTpresent, senescence, when_growthinit, &
+               everywhere, veget, & 
+               co2_to_bm, bm_to_litter, turnover_daily, bm_sapl, tree, cn_ind,flux10,flux100, &
+!!$               prod10,prod100,prod10_total,prod100_total,&
+!!$               convflux,cflux_prod_total,cflux_prod10,cflux_prod100,leaf_frac,&
+               prod10,prod100,convflux,cflux_prod10,cflux_prod100,leaf_frac,&
+               npp_longterm, lm_lastyearmax, litter, carbon)
+       ENDIF
+    ENDIF
+!MM dÃ©placement pour initialisation correcte des grandeurs cumulÃ©es :
+    cflux_prod_total(:) = convflux(:) + cflux_prod10(:) + cflux_prod100(:)
+    prod10_total(:)=SUM(prod10,dim=2)
+    prod100_total(:)=SUM(prod100,dim=2)
+    !
+    IF ( EndOfMonth ) THEN
+       cflux_prod_total_sum=SUM(cflux_prod_total(:)*resolution(:,1)*resolution(:,2)*contfrac(:))*1e-15
+       CALL reduce_sum(cflux_prod_total_sum,cflux_prod_sum)
+       CALL bcast(cflux_prod_sum)
+       WRITE(numout,*) 'net cflux_prod_total_sum (Peta gC/month)  = ',cflux_prod_total_sum
+       WRITE(numout,*) 'GLOBAL net cflux_prod_total_sum (Peta gC/month) (Peta gC/month)  = ',cflux_prod_sum
+    ENDIF
+
+    ! 16 total heterotrophic respiration
+
+    tot_soil_carb=zero
+    tot_litter_carb=zero
+    DO j=2,nvm
+
+       tot_litter_carb(:,j) = tot_litter_carb(:,j) + (litter(:,istructural,j,iabove) + &
+            &          litter(:,imetabolic,j,iabove) + &
+            &          litter(:,istructural,j,ibelow) + litter(:,imetabolic,j,ibelow))
+
+       tot_soil_carb(:,j) = tot_soil_carb(:,j) + (carbon(:,iactive,j) + &
+            &          carbon(:,islow,j)+  carbon(:,ipassive,j))
+
+    ENDDO
+    tot_litter_soil_carb = tot_litter_carb + tot_soil_carb
+
+    tot_live_biomass = biomass(:,:,ileaf) + biomass(:,:,isapabove) + biomass(:,:,isapbelow) +&
+         &             biomass(:,:,iheartabove) + biomass(:,:,iheartbelow) + &
+         &             biomass(:,:,iroot)+ biomass(:,:,ifruit)+ biomass(:,:,icarbres)
+
+    tot_turnover = turnover_daily(:,:,ileaf) + turnover_daily(:,:,isapabove) + &
+         &         turnover_daily(:,:,isapbelow) + turnover_daily(:,:,iheartabove) + &
+         &         turnover_daily(:,:,iheartbelow) + turnover_daily(:,:,iroot) + &
+         &         turnover_daily(:,:,ifruit) + turnover_daily(:,:,icarbres)
+
+    tot_bm_to_litter = bm_to_litter(:,:,ileaf) + bm_to_litter(:,:,isapabove) +&
+         &             bm_to_litter(:,:,isapbelow) + bm_to_litter(:,:,iheartbelow) +&
+         &             bm_to_litter(:,:,iheartabove) + bm_to_litter(:,:,iroot) + &
+         &             bm_to_litter(:,:,ifruit) + bm_to_litter(:,:,icarbres)
+
+    !
+    ! 17 history
+    !
+
+    ! 2d
+
+    CALL histwrite (hist_id_stomate, 'RESOLUTION_X', itime, &
+         resolution(:,1), npts, hori_index)
+    CALL histwrite (hist_id_stomate, 'RESOLUTION_Y', itime, &
+         resolution(:,2), npts, hori_index)
+    CALL histwrite (hist_id_stomate, 'CONTFRAC', itime, &
+         contfrac(:), npts, hori_index)
+
+    CALL histwrite (hist_id_stomate, 'LITTER_STR_AB', itime, &
+         litter(:,istructural,:,iabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'LITTER_MET_AB', itime, &
+         litter(:,imetabolic,:,iabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'LITTER_STR_BE', itime, &
+         litter(:,istructural,:,ibelow), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'LITTER_MET_BE', itime, &
+         litter(:,imetabolic,:,ibelow), npts*nvm, horipft_index)
+
+    CALL histwrite (hist_id_stomate, 'DEADLEAF_COVER', itime, &
+         deadleaf_cover, npts, hori_index)
+
+    CALL histwrite (hist_id_stomate, 'TOTAL_SOIL_CARB', itime, &
+         tot_litter_soil_carb, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'CARBON_ACTIVE', itime, &
+         carbon(:,iactive,:), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'CARBON_SLOW', itime, &
+         carbon(:,islow,:), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'CARBON_PASSIVE', itime, &
+         carbon(:,ipassive,:), npts*nvm, horipft_index)
+
+    CALL histwrite (hist_id_stomate, 'T2M_MONTH', itime, &
+         t2m_month, npts, hori_index)
+    CALL histwrite (hist_id_stomate, 'T2M_WEEK', itime, &
+         t2m_week, npts, hori_index)
+
+    CALL histwrite (hist_id_stomate, 'HET_RESP', itime, &
+         resp_hetero(:,:), npts*nvm, horipft_index)
+
+    CALL histwrite (hist_id_stomate, 'BLACK_CARBON', itime, &
+         black_carbon, npts, hori_index)
+
+    CALL histwrite (hist_id_stomate, 'FIREINDEX', itime, &
+         fireindex(:,:), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'LITTERHUM', itime, &
+         litterhum_daily, npts, hori_index)
+    CALL histwrite (hist_id_stomate, 'CO2_FIRE', itime, &
+         co2_fire, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'CO2_TAKEN', itime, &
+         co2_to_bm, npts*nvm, horipft_index)
+    ! land cover change
+    CALL histwrite (hist_id_stomate, 'CONVFLUX', itime, &
+         convflux, npts, hori_index)
+    CALL histwrite (hist_id_stomate, 'CFLUX_PROD10', itime, &
+         cflux_prod10, npts, hori_index)
+    CALL histwrite (hist_id_stomate, 'CFLUX_PROD100', itime, &
+         cflux_prod100, npts, hori_index)
+    CALL histwrite (hist_id_stomate, 'HARVEST_ABOVE', itime, &
+         harvest_above, npts, hori_index)
+
+    ! 3d
+
+    CALL histwrite (hist_id_stomate, 'LAI', itime, &
+         lai, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'VEGET', itime, &
+         veget, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'VEGET_MAX', itime, &
+         veget_max, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'NPP', itime, &
+         npp_daily, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'GPP', itime, &
+         gpp_daily, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'IND', itime, &
+         ind, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'TOTAL_M', itime, &
+         tot_live_biomass, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'LEAF_M', itime, &
+         biomass(:,:,ileaf), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'SAP_M_AB', itime, &
+         biomass(:,:,isapabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'SAP_M_BE', itime, &
+         biomass(:,:,isapbelow), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'HEART_M_AB', itime, &
+         biomass(:,:,iheartabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'HEART_M_BE', itime, &
+         biomass(:,:,iheartbelow), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'ROOT_M', itime, &
+         biomass(:,:,iroot), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'FRUIT_M', itime, &
+         biomass(:,:,ifruit), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'RESERVE_M', itime, &
+         biomass(:,:,icarbres), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'TOTAL_TURN', itime, &
+         tot_turnover, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'LEAF_TURN', itime, &
+         turnover_daily(:,:,ileaf), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'SAP_AB_TURN', itime, &
+         turnover_daily(:,:,isapabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'ROOT_TURN', itime, &
+         turnover_daily(:,:,iroot), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'FRUIT_TURN', itime, &
+         turnover_daily(:,:,ifruit), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'TOTAL_BM_LITTER', itime, &
+         tot_bm_to_litter, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'LEAF_BM_LITTER', itime, &
+         bm_to_litter(:,:,ileaf), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'SAP_AB_BM_LITTER', itime, &
+         bm_to_litter(:,:,isapabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'SAP_BE_BM_LITTER', itime, &
+         bm_to_litter(:,:,isapbelow), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'HEART_AB_BM_LITTER', itime, &
+         bm_to_litter(:,:,iheartabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'HEART_BE_BM_LITTER', itime, &
+         bm_to_litter(:,:,iheartbelow), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'ROOT_BM_LITTER', itime, &
+         bm_to_litter(:,:,iroot), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'FRUIT_BM_LITTER', itime, &
+         bm_to_litter(:,:,ifruit), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'RESERVE_BM_LITTER', itime, &
+         bm_to_litter(:,:,icarbres), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'MAINT_RESP', itime, &
+         resp_maint, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'GROWTH_RESP', itime, &
+         resp_growth, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'AGE', itime, &
+         age, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'HEIGHT', itime, &
+         height, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'MOISTRESS', itime, &
+         moiavail_week, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'VCMAX', itime, &
+         vcmax, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'TURNOVER_TIME', itime, &
+         turnover_time, npts*nvm, horipft_index)
+    ! land cover change
+    CALL histwrite (hist_id_stomate, 'PROD10', itime, &
+         prod10, npts*11, horip11_index)
+    CALL histwrite (hist_id_stomate, 'PROD100', itime, &
+         prod100, npts*101, horip101_index)
+    CALL histwrite (hist_id_stomate, 'FLUX10', itime, &
+         flux10, npts*10, horip10_index)
+    CALL histwrite (hist_id_stomate, 'FLUX100', itime, &
+         flux100, npts*100, horip100_index)
+
+    IF ( hist_id_stomate_IPCC > 0 ) THEN
+       vartmp(:)=SUM(tot_live_biomass*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cVeg", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(tot_litter_carb*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cLitter", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(tot_soil_carb*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cSoil", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=(prod10_total + prod100_total)/1e3
+       CALL histwrite (hist_id_stomate_IPCC, "cProduct", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(lai*veget_max,dim=2)*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "lai", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(gpp_daily*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "gpp", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM((resp_maint+resp_growth)*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "ra", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(npp_daily*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "npp", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(resp_hetero*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "rh", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(co2_fire*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "fFire", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=harvest_above/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "fHarvest", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=cflux_prod_total/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "fLuc", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=(SUM((gpp_daily-(resp_maint+resp_growth+resp_hetero)-co2_fire) &
+            &        *veget_max,dim=2)-cflux_prod_total-harvest_above)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "nbp", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(tot_bm_to_litter*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "fVegLitter", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(SUM(soilcarbon_input,dim=2)*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "fLitterSoil", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(biomass(:,:,ileaf)*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cLeaf", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM((biomass(:,:,isapabove)+biomass(:,:,iheartabove))*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cWood", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(( biomass(:,:,iroot) + biomass(:,:,isapbelow) + biomass(:,:,iheartbelow) ) &
+            &        *veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cRoot", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(( biomass(:,:,icarbres) + biomass(:,:,ifruit))*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cMisc", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM((litter(:,istructural,:,iabove)+litter(:,imetabolic,:,iabove))*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cLitterAbove", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM((litter(:,istructural,:,ibelow)+litter(:,imetabolic,:,ibelow))*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cLitterBelow", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(carbon(:,iactive,:)*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cSoilFast", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(carbon(:,islow,:)*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cSoilMedium", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(carbon(:,ipassive,:)*veget_max,dim=2)/1e3*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "cSoilSlow", itime, &
+         vartmp, npts, hori_index)
+       DO j=1,nvm
+          histvar(:,j)=veget_max(:,j)*contfrac(:)*100
+       ENDDO
+       CALL histwrite (hist_id_stomate_IPCC, "landCoverFrac", itime, &
+         histvar, npts*nvm, horipft_index)
+       vartmp(:)=(veget_max(:,3)+veget_max(:,6)+veget_max(:,8)+veget_max(:,9))*contfrac*100
+       CALL histwrite (hist_id_stomate_IPCC, "treeFracPrimDec", itime, &
+          vartmp, npts, hori_index)
+       vartmp(:)=(veget_max(:,2)+veget_max(:,4)+veget_max(:,5)+veget_max(:,7))*contfrac*100
+       CALL histwrite (hist_id_stomate_IPCC, "treeFracPrimEver", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=(veget_max(:,10)+veget_max(:,12))*contfrac*100
+       CALL histwrite (hist_id_stomate_IPCC, "c3PftFrac", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=(veget_max(:,11)+veget_max(:,13))*contfrac*100
+       CALL histwrite (hist_id_stomate_IPCC, "c4PftFrac", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(resp_growth*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "rGrowth", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(resp_maint*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "rMaint", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(bm_alloc(:,:,ileaf)*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "nppLeaf", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(bm_alloc(:,:,isapabove)*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "nppWood", itime, &
+         vartmp, npts, hori_index)
+       vartmp(:)=SUM(( bm_alloc(:,:,isapbelow) + bm_alloc(:,:,iroot) )*veget_max,dim=2)/1e3/one_day*contfrac
+       CALL histwrite (hist_id_stomate_IPCC, "nppRoot", itime, &
+         vartmp, npts, hori_index)
+
+       CALL histwrite (hist_id_stomate_IPCC, 'RESOLUTION_X', itime, &
+            resolution(:,1), npts, hori_index)
+       CALL histwrite (hist_id_stomate_IPCC, 'RESOLUTION_Y', itime, &
+            resolution(:,2), npts, hori_index)
+       CALL histwrite (hist_id_stomate_IPCC, 'CONTFRAC', itime, &
+            contfrac(:), npts, hori_index)
+
+    ENDIF
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving stomate_lpj'
+
+  END SUBROUTINE StomateLpj
+
+  SUBROUTINE harvest(npts, dt_days, veget_max, veget, &
+       bm_to_litter, turnover_daily, &
+       harvest_above)
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER, INTENT(in)                                            :: npts
+
+    ! Time step (days)
+    REAL(r_std), INTENT(in)                                         :: dt_days
+
+    ! new "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)                 :: veget_max
+    ! 0.2 modified fields
+
+    ! fractional coverage on natural/agricultural ground, taking into
+    !   account LAI (=grid-scale fpc)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                    :: veget
+
+    ! conversion of biomass to litter (gC/(m**2 of nat/agri ground)) / day
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)           :: bm_to_litter
+
+    ! Turnover rates (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)          :: turnover_daily
+    ! harvest above ground biomass for agriculture
+    REAL(r_std), DIMENSION(npts), INTENT(inout)                       :: harvest_above
+    ! 0.4 local
+
+    ! indices
+    INTEGER(i_std)                                                     :: i, j, k, l, m
+
+    ! biomass increase (gC/(m**2 of ground))
+    REAL(r_std)                                                        :: above_old
+    ! yearly initialisation
+    above_old             = zero
+    harvest_above         = zero
+    DO i = 1, npts
+       DO j=1, nvm
+          IF (j > 11) THEN
+             above_old = turnover_daily(i,j,ileaf) + turnover_daily(i,j,isapabove) + &
+                  &       turnover_daily(i,j,iheartabove) + turnover_daily(i,j,ifruit) + &
+                  &       turnover_daily(i,j,icarbres) + turnover_daily(i,j,isapbelow) + &
+                  &       turnover_daily(i,j,iheartbelow) + turnover_daily(i,j,iroot)
+
+             turnover_daily(i,j,ileaf) = turnover_daily(i,j,ileaf)*0.55
+             turnover_daily(i,j,isapabove) = turnover_daily(i,j,isapabove)*0.55
+             turnover_daily(i,j,isapbelow) = turnover_daily(i,j,isapbelow)*0.55
+             turnover_daily(i,j,iheartabove) = turnover_daily(i,j,iheartabove)*0.55
+             turnover_daily(i,j,iheartbelow) = turnover_daily(i,j,iheartbelow)*0.55
+             turnover_daily(i,j,iroot) = turnover_daily(i,j,iroot)*0.55
+             turnover_daily(i,j,ifruit) = turnover_daily(i,j,ifruit)*0.55
+             turnover_daily(i,j,icarbres) = turnover_daily(i,j,icarbres)*0.55
+             harvest_above(i)  = harvest_above(i) + veget_max(i,j) * above_old *0.45
+
+          ENDIF
+       ENDDO
+    ENDDO
+
+!!$    harvest_above = harvest_above
+  END SUBROUTINE harvest
+END MODULE stomate_lpj
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_npp.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_npp.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_npp.f90	(revision 55)
@@ -0,0 +1,519 @@
+! Npp: Maintenance and growth respiration
+! We calculte first the maintenance rspiration. This is substracted from the
+! allocatable biomass (and from the present biomass if the GPP is too low).
+! Of the rest, a part is lost as growth respiration, while the other part is
+! effectively allocated.
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_npp.f90,v 1.14 2010/04/20 14:12:04 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_npp
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC npp_calc,npp_calc_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE npp_calc_clear
+    firstcall=.TRUE.
+  END SUBROUTINE npp_calc_clear
+
+  SUBROUTINE npp_calc (npts, dt, &
+       PFTpresent, &
+       tlong_ref, t2m, tsoil, lai, rprof, &
+       gpp, f_alloc, bm_alloc, resp_maint_part,&
+       biomass, leaf_age, leaf_frac, age, &
+       resp_maint, resp_growth, npp)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                        :: npts
+    ! time step (days)
+    REAL(r_std), INTENT(in)                                     :: dt
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: PFTpresent
+    ! long term annual mean 2 meter reference temperature
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref
+    ! 2 meter temperature
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m
+    ! soil temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)               :: tsoil
+    ! leaf area index
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: lai
+    ! root depth (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: rprof
+    ! gross primary productivity (gC/days/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gpp
+    ! fraction that goes into plant part
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)        :: f_alloc
+    ! maintenance respiration of different plant parts (gC/day/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)             :: resp_maint_part
+
+    ! 0.2 modified fields
+
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: biomass
+    ! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
+    ! age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: age
+
+    ! 0.3 output
+
+    ! maintenance respiration (gC/day/m**2 of total ground)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: resp_maint
+    ! autotrophic respiration (gC/day/m**2 of total ground)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: resp_growth
+    ! net primary productivity (gC/day/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: npp
+    ! biomass increase, i.e. NPP per plant part
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)       :: bm_alloc
+
+    ! 0.4 local
+
+    ! maximum fraction of allocatable biomass used for maintenance respiration
+    REAL(r_std), PARAMETER                                      :: tax_max = 0.8
+    ! soil levels (m)
+    REAL(r_std), SAVE, DIMENSION(0:nbdl)                        :: z_soil
+    ! root temperature (convolution of root and soil temperature profiles)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: t_root
+    ! maintenance respiration coefficients at 0 deg C (g/g d**-1)
+    REAL(r_std), DIMENSION(npts,nvm,nparts)                    :: coeff_maint
+    ! temperature which is pertinent for maintenance respiration (K)
+    REAL(r_std), DIMENSION(npts,nparts)                         :: t_maint
+    ! integration constant for root profile
+    REAL(r_std), DIMENSION(npts)                                :: rpc
+    ! long term annual mean temperature, C
+    REAL(r_std), DIMENSION(npts)                                :: tl
+    ! slope of maintenance respiration coefficient (1/K)
+    REAL(r_std), DIMENSION(npts)                                :: slope
+    ! growth respiration of different plant parts (gC/day/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nparts)                         :: resp_growth_part
+    ! allocatable biomass (gC/m**2 of ground) for the whole plant
+    REAL(r_std), DIMENSION(npts,nvm)                           :: bm_alloc_tot
+    ! biomass increase
+    REAL(r_std), DIMENSION(npts)                                :: bm_add
+    ! new biomass
+    REAL(r_std), DIMENSION(npts)                                :: bm_new
+    ! leaf mass in youngest age class (gC/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: leaf_mass_young
+    ! leaf mass after maintenance respiration
+    REAL(r_std), DIMENSION(npts,nvm)                           :: lm_old
+    ! biomass created when biomass<0 because of dark respiration (gC/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: bm_create
+    ! maximum part of allocatable biomass used for respiration
+    REAL(r_std), DIMENSION(npts)                                :: bm_tax_max
+    ! biomass that remains to be taken away
+    REAL(r_std), DIMENSION(npts)                                :: bm_pump
+    ! Index
+    INTEGER(i_std)                                             :: i,j,k,l,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering npp'
+    !
+    ! 1 Initializations
+    !
+
+    !
+    ! 1.1 first call
+    !
+
+    IF ( firstcall ) THEN
+
+       ! 1.1.1 soil levels
+
+       z_soil(0) = zero
+       z_soil(1:nbdl) = diaglev(1:nbdl)
+
+       ! 1.1.2 messages
+
+       WRITE(numout,*) 'npp:'
+
+       WRITE(numout,*) '   > max. fraction of allocatable biomass used for'// &
+            ' maint. resp.:', tax_max
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 set output to zero
+    !
+
+    bm_alloc(:,:,:) = zero
+    resp_maint(:,:) = zero
+    resp_growth(:,:) = zero
+    npp(:,:) = zero
+
+    !
+    ! 1.3 root temperature: convolution of root and temperature profiles
+    !     suppose exponential root profile.
+    !
+
+    DO j = 2,nvm
+
+       ! 1.3.1 rpc is an integration constant such that the integral of the root profile is un
+       rpc(:) = un / ( un - EXP( -z_soil(nbdl) / rprof(:,j) ) )
+
+       ! 1.3.2 integrate over the nbdl levels
+
+       t_root(:,j) = zero
+
+       DO l = 1, nbdl
+
+          t_root(:,j) = &
+               t_root(:,j) + tsoil(:,l) * rpc(:) * &
+               ( EXP( -z_soil(l-1)/rprof(:,j) ) - EXP( -z_soil(l)/rprof(:,j) ) )
+
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 1.4 total allocatable biomass
+    !
+
+    bm_alloc_tot(:,:) = gpp(:,:) * dt
+
+    !
+    ! 2 define maintenance respiration coefficients
+    !
+
+    DO j = 2,nvm
+
+       !
+       ! 2.1 temperature which is taken for the plant part we are talking about
+       !
+
+       ! 2.1.1 parts above the ground
+
+       t_maint(:,ileaf) = t2m(:)
+       t_maint(:,isapabove) = t2m(:)
+       t_maint(:,ifruit) = t2m(:)
+
+       ! 2.1.2 parts below the ground
+
+       t_maint(:,isapbelow) = t_root(:,j)
+       t_maint(:,iroot) = t_root(:,j)
+
+       ! 2.1.3 heartwood: does not respire. Any temperature
+
+       t_maint(:,iheartbelow) = t_root(:,j)
+       t_maint(:,iheartabove) = t2m(:)
+
+       ! 2.1.4 reserve: above the ground for trees, below for grasses
+
+       IF ( tree(j) ) THEN
+          t_maint(:,icarbres) = t2m(:)
+       ELSE
+          t_maint(:,icarbres) = t_root(:,j)
+       ENDIF
+
+       !
+       ! 2.2 calculate coefficient
+       !
+
+       tl(:) = tlong_ref(:) - ZeroCelsius
+       slope(:) = maint_resp_slope(j,1) + tl(:) * maint_resp_slope(j,2) + &
+            tl(:)*tl(:) * maint_resp_slope(j,3)
+
+       DO k = 1, nparts
+
+          coeff_maint(:,j,k) = &
+               MAX( coeff_maint_zero(j,k) * &
+               ( un + slope(:) * (t_maint(:,k)-ZeroCelsius) ), zero )
+
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 3 calculate maintenance and growth respiration.
+    !   NPP = GPP - maintenance resp - growth resp.
+    !
+    !
+    DO j = 2,nvm
+
+       !
+       ! 3.1 maintenance respiration of the different plant parts
+       !
+       !
+       ! 3.2 Total maintenance respiration of the plant
+       !     VPP killer:
+       !     resp_maint(:,j) = SUM( resp_maint_part(:,:), DIM=2 )
+       !
+
+       resp_maint(:,j) = zero
+
+       ! with the new calculation of hourly respiration, we must verify that 
+       ! PFT has not been killed after calcul of resp_maint_part in stomate
+       DO k= 1, nparts
+          WHERE (PFTpresent(:,j))
+             resp_maint(:,j) = resp_maint(:,j) + resp_maint_part(:,j,k)
+          ENDWHERE
+       ENDDO
+       !
+       ! 3.3 This maintenance respiration is taken away from the newly produced 
+       !     allocatable biomass. However, we avoid that no allocatable biomass remains.
+       !     If the respiration is larger than a given fraction of the allocatable biomass,
+       !     the rest is taken from the tissues themselves.
+       !     We suppose that respiration is not dependent on leaf age -> 
+       !     do not change age structure.
+       !
+
+       ! maximum part of allocatable biomass used for respiration
+       bm_tax_max(:) = tax_max * bm_alloc_tot(:,j)
+
+       DO i = 1, npts
+
+          IF ( ( bm_alloc_tot(i,j) .GT. zero ) .AND. &
+               ( ( resp_maint(i,j) * dt ) .LT. bm_tax_max(i) ) ) THEN
+
+             bm_alloc_tot(i,j) = bm_alloc_tot(i,j) - resp_maint(i,j) * dt
+
+             !Shilong        ELSEIF ( resp_maint(i,j) .GT. zero ) THEN
+          ELSEIF ( resp_maint(i,j) .GT. min_stomate ) THEN
+
+             ! remaining allocatable biomass
+             bm_alloc_tot(i,j) = bm_alloc_tot(i,j) - bm_tax_max(i)
+
+             ! biomass that remains to be taken away from tissues
+             bm_pump(i) = resp_maint(i,j) * dt - bm_tax_max(i)
+
+             ! take biomass from tissues
+
+             biomass(i,j,ileaf) = biomass(i,j,ileaf) - &
+                  bm_pump(i) * resp_maint_part(i,j,ileaf) / resp_maint(i,j)
+             biomass(i,j,isapabove) = biomass(i,j,isapabove) - &
+                  bm_pump(i) * resp_maint_part(i,j,isapabove) / resp_maint(i,j)
+             biomass(i,j,isapbelow) = biomass(i,j,isapbelow) - &
+                  bm_pump(i) * resp_maint_part(i,j,isapbelow) / resp_maint(i,j)
+             biomass(i,j,iroot) = biomass(i,j,iroot) - &
+                  bm_pump(i) * resp_maint_part(i,j,iroot) / resp_maint(i,j)
+             biomass(i,j,ifruit) = biomass(i,j,ifruit) - &
+                  bm_pump(i) * resp_maint_part(i,j,ifruit) / resp_maint(i,j)
+             biomass(i,j,icarbres) = biomass(i,j,icarbres) - &
+                  bm_pump(i) * resp_maint_part(i,j,icarbres) / resp_maint(i,j)
+
+          ENDIF
+
+       ENDDO   ! Fortran95: WHERE - ELSEWHERE construct
+
+       !
+       ! 3.4 dispatch allocatable biomass
+       !
+
+       DO k = 1, nparts
+          bm_alloc(:,j,k) = f_alloc(:,j,k) * bm_alloc_tot(:,j)
+       ENDDO
+
+       !
+       ! 3.5 growth respiration of a plant part is a given fraction of the
+       !     remaining allocatable biomass.
+       !
+
+       resp_growth_part(:,:) = frac_growthresp * bm_alloc(:,j,:) / dt
+
+       bm_alloc(:,j,:) = ( un - frac_growthresp ) * bm_alloc(:,j,:)
+
+       !
+       ! 3.6 Total growth respiration of the plant
+       !     VPP killer:
+       !     resp_growth(:,j) = SUM( resp_growth_part(:,:), DIM=2 )
+       !
+
+       resp_growth(:,j) = zero
+
+       DO k = 1, nparts
+          resp_growth(:,j) = resp_growth(:,j) + resp_growth_part(:,k)
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 4 update the biomass, but save the old leaf mass for later
+    !   "old" leaf mass is leaf mass after maintenance respiration
+    !
+
+    lm_old(:,:) = biomass(:,:,ileaf)
+
+    biomass(:,:,:) = biomass(:,:,:) + bm_alloc(:,:,:)
+
+    !
+    ! 5 biomass can become negative in some rare cases, as the GPP can be negative
+    !   (dark respiration).
+    !   In this case, set biomass to some small value. This creation of matter is taken into
+    !   account by decreasing the autotrophic respiration. In this case, maintenance respiration
+    !   can become negative !!!
+    ! 
+
+    DO k = 1, nparts
+
+       DO j = 2,nvm
+
+          WHERE ( biomass(:,j,k) .LT. zero )
+
+             bm_create(:,j) = min_stomate - biomass(:,j,k)
+             
+             biomass(:,j,k) = biomass(:,j,k) + bm_create(:,j)
+             
+             resp_maint(:,j) = resp_maint(:,j) - bm_create(:,j) / dt
+
+          ENDWHERE
+
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 6 Calculate the NPP (gC/(m**2 of ground/day)
+    !
+
+    DO j = 2,nvm
+       npp(:,j) = gpp(:,j) - resp_growth(:,j) - resp_maint(:,j)
+    ENDDO
+
+    !
+    ! 7 leaf age
+    !
+
+    !
+    ! 7.1 Decrease leaf age in youngest class if new leaf biomass is higher than old one.
+    !
+
+    DO j = 2,nvm
+       leaf_mass_young(:,j) = leaf_frac(:,j,1) * lm_old(:,j) + bm_alloc(:,j,ileaf)
+    ENDDO
+
+    DO j = 2,nvm
+       WHERE ( ( bm_alloc(:,j,ileaf) .GT. zero ) .AND. &
+         ( leaf_mass_young(:,j) .GT. zero ) )
+
+          leaf_age(:,j,1) = MAX ( zero, &
+               & leaf_age(:,j,1) * &
+               & ( leaf_mass_young(:,j) - bm_alloc(:,j,ileaf) ) / &
+               & leaf_mass_young(:,j) )
+          
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 7.2 new age class fractions (fraction in youngest class increases)
+    !
+
+    ! 7.2.1 youngest class: new mass in youngest class divided by total new mass
+
+    DO j = 2,nvm
+       WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
+
+          leaf_frac(:,j,1) = leaf_mass_young(:,j) / biomass(:,j,ileaf)
+
+       ENDWHERE
+    ENDDO
+
+    ! 7.2.2 other classes: old mass in leaf age class divided by new mass
+
+    DO m = 2, nleafages
+
+       DO j = 2,nvm
+          WHERE ( biomass(:,j,ileaf) .GT. min_stomate )
+
+             leaf_frac(:,j,m) = leaf_frac(:,j,m) * lm_old(:,j) / biomass(:,j,ileaf)
+
+          ENDWHERE
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 8 Plant age (years)
+    !
+
+    !
+    ! 8.1 Increase age at every time step
+    !
+
+    WHERE ( PFTpresent(:,:) )
+
+       age(:,:) = age(:,:) + dt/one_year
+
+    ELSEWHERE
+
+       age(:,:) = zero
+
+    ENDWHERE
+
+    !
+    ! 8.2 For grasses, decrease age
+    !     if new biomass is higher than old one.
+    !     For trees, age is treated in "establish" if vegetation is dynamic,
+    !     and in turnover routines if it is static (in this case, only take 
+    !     into account the age of the heartwood).
+    !
+
+    DO j = 2,nvm
+
+       IF ( .NOT. tree(j) ) THEN
+
+          ! Only four compartments for grasses
+          ! VPP killer:
+          ! bm_new(:) = SUM( biomass(:,j,:), DIM=2 )
+          ! bm_add(:) = SUM( bm_alloc(:,j,:), DIM=2 )
+
+          bm_new(:) = biomass(:,j,ileaf) + biomass(:,j,isapabove) + &
+               biomass(:,j,iroot) + biomass(:,j,ifruit)
+          bm_add(:) = bm_alloc(:,j,ileaf) + bm_alloc(:,j,isapabove) + &
+               bm_alloc(:,j,iroot) + bm_alloc(:,j,ifruit)
+
+          WHERE ( ( bm_new(:) .GT. zero ) .AND. ( bm_add(:) .GT. zero ) )
+             age(:,j) = age(:,j) * ( bm_new(:) - bm_add(:) ) / bm_new(:)
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 9 history
+    !
+
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_LEAF', itime, &
+         bm_alloc(:,:,ileaf), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_AB', itime, &
+         bm_alloc(:,:,isapabove), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_SAP_BE', itime, &
+         bm_alloc(:,:,isapbelow), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_ROOT', itime, &
+         bm_alloc(:,:,iroot), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_FRUIT', itime, &
+         bm_alloc(:,:,ifruit), npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'BM_ALLOC_RES', itime, &
+         bm_alloc(:,:,icarbres), npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving npp'
+
+  END SUBROUTINE npp_calc
+
+END MODULE stomate_npp
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_phenology.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_phenology.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_phenology.f90	(revision 55)
@@ -0,0 +1,1153 @@
+! Phenology
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_phenology.f90,v 1.11 2010/04/06 16:06:34 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_phenology
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC phenology,phenology_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+  LOGICAL, SAVE                                              :: firstcall_hum = .TRUE.
+  LOGICAL, SAVE                                              :: firstcall_moi = .TRUE.
+  LOGICAL, SAVE                                              :: firstcall_humgdd = .TRUE.
+  LOGICAL, SAVE                                              :: firstcall_moigdd = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE phenology_clear
+    firstcall=.TRUE.
+    firstcall_hum=.TRUE.
+    firstcall_moi = .TRUE.
+    firstcall_humgdd = .TRUE.
+    firstcall_moigdd = .TRUE.
+  END SUBROUTINE phenology_clear
+
+  SUBROUTINE phenology (npts, dt, PFTpresent, &
+       veget_max, &
+       tlong_ref, t2m_month, t2m_week, gpp, &
+       maxmoiavail_lastyear, minmoiavail_lastyear, &
+       moiavail_month, moiavail_week, &
+       gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, &
+       senescence, time_lowgpp, time_hum_min, &
+       biomass, leaf_frac, leaf_age, &
+       when_growthinit, co2_to_bm, lai)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                        :: npts
+    ! time step in days
+    REAL(r_std), INTENT(in)                                     :: dt
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: PFTpresent
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max
+    ! "long term" 2 meter reference temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_month
+    ! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_week
+    ! daily gross primary productivity (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gpp
+    ! last year's maximum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: maxmoiavail_lastyear
+    ! last year's minimum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: minmoiavail_lastyear
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_month
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_week
+    ! growing degree days, threshold -5 deg C
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: gdd_m5_dormance
+    ! growing degree days, since midwinter
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)               :: gdd_midwinter
+    ! number of chilling days since leaves were lost
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: ncd_dormance
+    ! number of growing days, threshold -5 deg C
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: ngd_minus5
+    ! is the plant senescent? (only for deciduous trees - carbohydrate reserve)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: senescence
+    ! duration of dormance (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: time_lowgpp
+    ! time elapsed since strongest moisture availability (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: time_hum_min
+
+    ! 0.2 modified fields
+
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: biomass
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
+    ! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: when_growthinit
+    ! co2 taken up (gC/(m**2 of total ground)/day)
+    !NV passge 2D
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)                 :: co2_to_bm
+
+    ! 0.3 output
+
+    ! leaf area index
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)              :: lai
+
+    ! 0.4 local
+
+    ! take carbon from atmosphere if carbohydrate reserve too small?
+    LOGICAL, PARAMETER                                         :: always_init = .FALSE.
+    ! minimum time (d) since last beginning of a growing season
+    REAL(r_std), PARAMETER                                      :: min_growthinit_time = 300.
+    ! are we allowed to decalre the beginning of the growing season?
+    LOGICAL, DIMENSION(npts,nvm)                              :: allow_initpheno
+    ! biomass we would like to have
+    REAL(r_std), DIMENSION(npts)                                :: bm_wanted
+    ! biomass we use (from carbohydrate reserve or from atmosphere)
+    REAL(r_std), DIMENSION(npts)                                :: bm_use
+    ! minimum leaf mass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: lm_min
+    ! does the leaf age distribution have to be reset?
+    LOGICAL(r_std), DIMENSION(npts)                             :: age_reset
+    ! indices
+    INTEGER(i_std)                                              :: i,j,m
+    ! signal to start putting leaves on
+    LOGICAL, DIMENSION(npts,nvm)                              :: begin_leaves
+
+    REAL(r_std), DIMENSION(npts,nvm)                          :: histvar
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering phenology'
+
+    !
+    ! 1 first call
+    !
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'phenology:'
+
+       WRITE(numout,*) '   > take carbon from atmosphere if carbohydrate' // &
+            ' reserve too small: ', always_init
+
+       WRITE(numout,*) '   > minimum time since last beginning of a growing' // &
+            ' season (d): ', min_growthinit_time
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 2 various things
+    !
+
+    !
+    ! 2.1 allow detection of the beginning of the growing season if dormance was
+    !     long enough and last beginning of growing season was a sufficiently 
+    !     long time ago
+    !
+
+    allow_initpheno(:,1) = .FALSE.
+    DO j = 2,nvm
+
+       WHERE ( ( time_lowgpp(:,j) .GE. pheno_crit%lowgpp_time(j) ) .AND. &
+            ( when_growthinit(:,j) .GT. min_growthinit_time )          )
+          allow_initpheno(:,j) = .TRUE.
+       ELSEWHERE
+          allow_initpheno(:,j) = .FALSE.
+       ENDWHERE
+
+    ENDDO
+
+    WHERE(allow_initpheno)
+       histvar=un
+    ELSEWHERE
+       histvar=zero
+    ENDWHERE
+    CALL histwrite (hist_id_stomate, 'ALLOW_INITPHENO', itime, histvar, npts*nvm, horipft_index)
+
+    !
+    ! 2.2 increase counter: how many days ago was the beginning of the growing season
+    !     Needed for allocation
+    !
+
+    when_growthinit(:,:) = when_growthinit(:,:) + dt
+
+    !
+    ! 3 Check biometeorological conditions
+    !
+
+    ! default: phenology does not start
+    begin_leaves(:,:) = .FALSE.
+
+    ! different kinds of phenology
+
+    DO j = 2,nvm
+
+       SELECT CASE ( pheno_crit%pheno_model(j) )
+
+       CASE ( 'hum' )
+
+          CALL pheno_hum (npts, j, PFTpresent, allow_initpheno, &
+               moiavail_month, moiavail_week, &
+               maxmoiavail_lastyear, minmoiavail_lastyear, &
+               begin_leaves)
+
+       CASE ( 'moi' )
+
+          CALL pheno_moi (npts, j, PFTpresent, allow_initpheno, &
+               time_hum_min, &
+               moiavail_month, moiavail_week, &
+               begin_leaves)
+
+
+       CASE ( 'ncdgdd' )
+
+          CALL pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
+               ncd_dormance, gdd_midwinter, &
+               t2m_month, t2m_week, begin_leaves)
+
+       CASE ( 'ngd' )
+
+          CALL pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd_minus5, &
+               t2m_month, t2m_week, begin_leaves)
+
+       CASE ( 'humgdd' )
+
+          CALL pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
+               maxmoiavail_lastyear, minmoiavail_lastyear, &
+               tlong_ref, t2m_month, t2m_week, &
+               moiavail_week, moiavail_month, &
+               begin_leaves)
+
+       CASE ( 'moigdd' )
+
+          CALL pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd_m5_dormance, &
+               time_hum_min, &
+               tlong_ref, t2m_month, t2m_week, &
+               moiavail_week, moiavail_month, &
+               begin_leaves)
+
+       CASE ( 'none' )
+
+          ! no action
+
+       CASE default
+
+          WRITE(numout,*) 'phenology: don''t know how to treat this PFT.'
+          WRITE(numout,*) '  number:',j
+          WRITE(numout,*) '  phenology model: ',pheno_crit%pheno_model(j)
+          STOP
+
+       END SELECT
+
+    ENDDO
+
+    WHERE(begin_leaves)
+       histvar=un
+    ELSEWHERE
+       histvar=zero
+    ENDWHERE
+    CALL histwrite (hist_id_stomate, 'BEGIN_LEAVES', itime, histvar, npts*nvm, horipft_index)
+
+    !
+    ! 4 leaves start to grow if meteorological conditions are favourable and if
+    !   leaf regrowth is allowed (cf also turnover)
+    !
+
+    DO j = 2,nvm
+
+       age_reset(:) = .FALSE.
+
+       DO i = 1, npts
+
+          IF ( begin_leaves(i,j) ) THEN
+
+             lm_min(i) = pheno_crit%lai_initmin(j) / sla(j)
+
+             ! do we have to put a minimum biomass into the leaves?
+
+             IF ( biomass(i,j,ileaf) .LT. lm_min(i) ) THEN
+
+                !
+                ! 4.1 determine how much biomass we can use
+                !
+
+                bm_wanted(i) = 2. * lm_min(i)
+
+                ! eventually take the missing carbon from the atmosphere and
+                ! put it into carbohydrate reserve
+
+                IF ( always_init .AND. ( biomass(i,j,icarbres) .LT. bm_wanted(i) ) ) THEN
+                   !NV passage 2D
+                   co2_to_bm(i,j) = co2_to_bm(i,j) + ( bm_wanted(i) - biomass(i,j,icarbres) ) / dt
+
+                   biomass(i,j,icarbres) = bm_wanted(i)
+
+                ENDIF
+
+                bm_use(i) = MIN( biomass(i,j,icarbres), bm_wanted(i) )
+
+                !
+                ! 4.2 dispatch that biomass on leaves and roots
+                !
+
+                biomass(i,j,ileaf) = biomass(i,j,ileaf) + bm_use(i) / 2.
+
+                biomass(i,j,iroot) = biomass(i,j,iroot) + bm_use(i) / 2.
+
+                !
+                ! 4.3 decrease reservoir biomass
+                !
+
+                biomass(i,j,icarbres) = biomass(i,j,icarbres) - bm_use(i)
+
+                !
+                ! 4.4 decide whether we have to reset then leaf age distribution
+                !     (done later for better vectorization)
+                !
+
+                age_reset(i) = .TRUE.
+
+             ENDIF  ! leaf mass is very low
+
+             !
+             ! 4.5 reset counter: start of the growing season
+             !
+
+             when_growthinit(i,j) = 0.0
+
+          ENDIF    ! start of the growing season
+
+       ENDDO      ! loop over grid points
+
+       !
+       ! 4.6 reset leaf age distribution where necessary
+       !     simply say that everything is in the youngest age class
+       !
+
+       ! 4.6.1 fractions
+
+       WHERE ( age_reset(:) )
+          leaf_frac(:,j,1) = un
+       ENDWHERE
+       DO m = 2, nleafages
+          WHERE ( age_reset(:) )
+             leaf_frac(:,j,m) = zero
+          ENDWHERE
+       ENDDO
+
+       ! 4.6.2 ages
+
+       DO m = 1, nleafages
+          WHERE ( age_reset(:) )
+             leaf_age(:,j,m) = zero
+          ENDWHERE
+       ENDDO
+
+    ENDDO        ! loop over PFTs
+
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving phenology'
+
+  END SUBROUTINE phenology
+
+  !
+  ! ==============================================================================
+  ! Phenology: begins if "weekly" soil humidity starts to exceed a certain threshold
+  !            value. This value depends on last year's max and min humidity ...
+  !            Always initiate growing season if soil moisture exceeds a certain threshold.
+  !
+
+  SUBROUTINE pheno_hum (npts, j, PFTpresent, allow_initpheno, &
+       moiavail_month, moiavail_week, &
+       maxmoiavail_lastyear, minmoiavail_lastyear, &
+       begin_leaves)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                     :: npts
+    ! PFT index
+    INTEGER(i_std), INTENT(in)                               :: j
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
+    ! are we allowed to decalre the beginning of the growing season?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
+    ! last year's maximum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: maxmoiavail_lastyear
+    ! last year's minimum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: minmoiavail_lastyear
+
+    ! 0.2 output
+
+    ! signal to start putting leaves on
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves
+
+    ! 0.3 local
+
+    ! moisture availability above which moisture tendency doesn't matter
+    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = un
+    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
+    REAL(r_std)                                              :: moiavail_always
+    ! first call
+    REAL(r_std), DIMENSION(npts)                             :: availability_crit
+    ! index
+    INTEGER(i_std)                                           :: i
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering hum'
+
+    !
+    ! Initializations
+    !
+
+    !
+    ! 1.1 messages
+    !
+
+    IF ( firstcall_hum ) THEN
+
+       WRITE(numout,*) 'pheno_hum:'
+       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
+       WRITE(numout,*) '         trees:', moiavail_always_tree
+       WRITE(numout,*) '         grasses:', moiavail_always_grass
+
+       firstcall_hum = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    ! 1.3 check the prescribed critical value
+    !
+
+    IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'hum: pheno_crit%hum_frac is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    ! 1.4 critical moisture availability above which we always detect the beginning of the
+    !     growing season.
+    !
+
+    IF ( tree(j) ) THEN
+       moiavail_always = moiavail_always_tree
+    ELSE
+       moiavail_always = moiavail_always_grass
+    ENDIF
+
+    !
+    ! 2 PFT has to be there and start of growing season must be allowed
+    !
+
+    DO i = 1, npts
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
+
+          ! critical availability: depends on last year's max and min.
+
+          availability_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
+               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
+
+          ! the favorable season starts if the "monthly" moisture availability is still quite
+          ! low, but the "weekly" availability is already higher (as it reacts faster).
+          ! If monthly moisture availability is high enough, also initiate growing season if
+          ! this has not happened yet.
+
+          IF ( ( ( moiavail_week(i,j)  .GE. availability_crit(i) ) .AND. &
+               ( moiavail_month(i,j) .LT. moiavail_week(i,j) )   ) .OR. &
+               ( moiavail_month(i,j) .GE. moiavail_always )                ) THEN
+             begin_leaves(i,j) = .TRUE.
+          ENDIF
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving hum'
+
+  END SUBROUTINE pheno_hum
+
+  !
+  ! ==============================================================================
+  ! Phenology: begins if moisture minium was a sufficiently long time ago.
+  !            Additionally, "weekly" soil humidity must be higher that "monthly" soil
+  !            humidity.
+  !
+
+  SUBROUTINE pheno_moi (npts, j, PFTpresent, allow_initpheno, &
+       time_hum_min, &
+       moiavail_month, moiavail_week, &
+       begin_leaves)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                     :: npts
+    ! PFT index
+    INTEGER(i_std), INTENT(in)                               :: j
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
+    ! are we allowed to decalre the beginning of the growing season?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
+    ! time elapsed since strongest moisture availability (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: time_hum_min
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
+
+    ! 0.2 output
+
+    ! signal to start putting leaves on
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves
+
+    ! 0.3 local
+
+    ! moisture availability above which moisture tendency doesn't matter
+    ! moisture availability above which moisture tendency doesn't matter
+    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = un
+    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
+    REAL(r_std)                                              :: moiavail_always
+    ! index
+    INTEGER(i_std)                                           :: i
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering moi'
+
+    !
+    ! Initializations
+    !
+
+    !
+    ! 1.1 messages
+    !
+
+    IF ( firstcall_moi ) THEN
+
+       WRITE(numout,*) 'pheno_moi:'
+       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
+       WRITE(numout,*) '         trees:', moiavail_always_tree
+       WRITE(numout,*) '         grasses:', moiavail_always_grass
+
+       firstcall_moi = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    ! 1.3 check the prescribed critical value
+    !
+
+    IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'moi: pheno_crit%hum_min_time is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    ! 1.4 critical moisture availability above which we always detect the beginning of the
+    !     growing season.
+    !
+
+    IF ( tree(j) ) THEN
+       moiavail_always = moiavail_always_tree
+    ELSE
+       moiavail_always = moiavail_always_grass
+    ENDIF
+
+    !
+    ! 2 PFT has to be there and start of growing season must be allowed
+    !
+
+    DO i = 1, npts
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
+
+          ! the favorable season starts if the moisture minimum was a sufficiently long 
+          ! time ago and if the "monthly" moisture availability is lower than the "weekly"
+          ! availability (this means that soil moisture is increasing).
+          ! If monthly moisture availability is high enough, also initiate growing season if
+          ! this has not happened yet.
+
+          IF  ( ( ( moiavail_week(i,j) .GT. moiavail_month(i,j) ) .AND. &
+               ( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) )    ) .OR. &
+               ( moiavail_month(i,j) .GE. moiavail_always )                     ) THEN
+             begin_leaves(i,j) = .TRUE.
+          ENDIF
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving moi'
+
+  END SUBROUTINE pheno_moi
+
+  !
+  ! ==============================================================================
+  ! Phenology: leaves are put on if gdd exceeds a critical value.
+  !            Additionally, there has to be at least some moisture.
+  !            Set gdd to undef if beginning of the growing season detected.
+  !
+
+  SUBROUTINE pheno_humgdd (npts, j, PFTpresent, allow_initpheno, gdd, &
+       maxmoiavail_lastyear, minmoiavail_lastyear, &
+       tlong_ref, t2m_month, t2m_week, &
+       moiavail_week, moiavail_month, &
+       begin_leaves)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                     :: npts
+    ! PFT index
+    INTEGER(i_std), INTENT(in)                               :: j
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
+    ! are we allowed to decalre the beginning of the growing season?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
+    ! growing degree days, calculated since leaves have fallen
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: gdd
+    ! last year's maximum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: maxmoiavail_lastyear
+    ! last year's minimum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: minmoiavail_lastyear
+    ! "long term" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
+    ! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
+
+    ! 0.2 output
+
+    ! signal to start putting leaves on
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves
+
+    ! 0.3 local
+
+    ! moisture availability above which moisture tendency doesn't matter
+    ! moisture availability above which moisture tendency doesn't matter
+    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = un
+    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
+    REAL(r_std)                                              :: moiavail_always
+    ! monthly temp. above which temp. tendency doesn't matter
+    REAL(r_std), PARAMETER                                   :: t_always = ZeroCelsius + 10.
+    ! critical moisture availability
+    REAL(r_std), DIMENSION(npts)                             :: moiavail_crit
+    ! long term temperature, C
+    REAL(r_std), DIMENSION(npts)                             :: tl
+    ! critical GDD
+    REAL(r_std), DIMENSION(npts)                             :: gdd_crit
+    ! index
+    INTEGER(i_std)                                           :: i
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering humgdd'
+
+    !
+    ! 1 Initializations
+    !
+
+    !
+    ! 1.1 messages
+    !
+
+    IF ( firstcall_humgdd ) THEN
+
+       WRITE(numout,*) 'pheno_humgdd:'
+       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
+       WRITE(numout,*) '         trees:', moiavail_always_tree
+       WRITE(numout,*) '         grasses:', moiavail_always_grass
+       WRITE(numout,*) '   > monthly temp. above which temp. tendency doesn''t matter: ', &
+            t_always
+
+       firstcall_humgdd = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    ! 1.3 check the prescribed critical values
+    !
+
+    IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
+
+       WRITE(numout,*) 'humgdd: pheno_crit%gdd is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    IF ( pheno_crit%hum_frac(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'humgdd: pheno_crit%hum_frac is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    ! 1.4 critical moisture availability above which we always detect the beginning of the
+    !     growing season.
+    !
+
+    IF ( tree(j) ) THEN
+       moiavail_always = moiavail_always_tree
+    ELSE
+       moiavail_always = moiavail_always_grass
+    ENDIF
+
+    !
+    ! 2 PFT has to be there, start of growing season must be allowed, 
+    !   and gdd has to be defined
+    !
+
+    DO i = 1, npts
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
+            ( gdd(i,j) .NE. undef )                           ) THEN
+
+          ! is critical gdd reached and is temperature increasing?
+          ! be sure that at least some humidity
+
+          moiavail_crit(i) = minmoiavail_lastyear(i,j) + pheno_crit%hum_frac(j) * &
+               ( maxmoiavail_lastyear(i,j) - minmoiavail_lastyear(i,j) )
+
+          tl(i) = tlong_ref(i) - ZeroCelsius
+          gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
+               tl(i)*tl(i)*pheno_crit%gdd(j,3)
+
+          IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
+               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
+               ( t2m_month(i) .GT. t_always )          ) .AND. &
+               ( ( ( moiavail_week(i,j)  .GE. moiavail_crit(i) ) .AND. &
+               ( moiavail_month(i,j) .LT. moiavail_crit(i) )        ) .OR. &
+               ( moiavail_month(i,j) .GE. moiavail_always )                   ) )  THEN
+             begin_leaves(i,j) = .TRUE.
+          ENDIF
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving humgdd'
+
+  END SUBROUTINE pheno_humgdd
+
+  !
+  ! ==============================================================================
+  ! Phenology: leaves are put on if gdd exceeds a critical value.
+  !            Additionally, a certain time must have elapsed since the moisture minimum.
+  !            Set gdd to undef if beginning of the growing season detected.
+  !
+
+  SUBROUTINE pheno_moigdd (npts, j, PFTpresent, allow_initpheno, gdd, &
+       time_hum_min, &
+       tlong_ref, t2m_month, t2m_week, &
+       moiavail_week, moiavail_month, &
+       begin_leaves)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                     :: npts
+    ! PFT index
+    INTEGER(i_std), INTENT(in)                               :: j
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
+    ! are we allowed to decalre the beginning of the growing season?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
+    ! growing degree days, calculated since leaves have fallen
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: gdd
+    ! time elapsed since strongest moisture availability (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: time_hum_min
+    ! "long term" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: tlong_ref
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
+    ! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_week
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: moiavail_month
+
+    ! 0.2 output
+
+    ! signal to start putting leaves on
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves
+
+    ! 0.3 local
+
+    ! moisture availability above which moisture tendency doesn't matter
+    ! moisture availability above which moisture tendency doesn't matter
+    REAL(r_std), PARAMETER                                   :: moiavail_always_tree = un
+    REAL(r_std), PARAMETER                                   :: moiavail_always_grass = 0.6
+    REAL(r_std)                                              :: moiavail_always
+    ! monthly temp. above which temp. tendency doesn't matter
+    REAL(r_std), PARAMETER                                   :: t_always = ZeroCelsius + 10.
+    ! long term temperature, C
+    REAL(r_std), DIMENSION(npts)                             :: tl
+    ! critical GDD
+    REAL(r_std), DIMENSION(npts)                             :: gdd_crit
+    ! index
+    INTEGER(i_std)                                           :: i
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering moigdd'
+
+    !
+    ! 1 Initializations
+    !
+
+    !
+    ! 1.1 messages
+    !
+
+    IF ( firstcall_moigdd ) THEN
+
+       WRITE(numout,*) 'pheno_moigdd:'
+       WRITE(numout,*) '   > moisture availability above which moisture tendency doesn''t matter: '
+       WRITE(numout,*) '         trees:', moiavail_always_tree
+       WRITE(numout,*) '         grasses:', moiavail_always_grass
+       WRITE(numout,*) '   > monthly temp. above which temp. tendency doesn''t matter: ', &
+            t_always
+
+       firstcall_moigdd = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    ! 1.3 check the prescribed critical values
+    !
+
+    IF ( ANY(pheno_crit%gdd(j,:) .EQ. undef) ) THEN
+
+       WRITE(numout,*) 'moigdd: pheno_crit%gdd is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    IF ( pheno_crit%hum_min_time(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'moigdd: pheno_crit%hum_min_time is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    ! 1.4 critical moisture availability above which we always detect the beginning of the
+    !     growing season.
+    !
+
+    IF ( tree(j) ) THEN
+       moiavail_always = moiavail_always_tree
+    ELSE
+       moiavail_always = moiavail_always_grass
+    ENDIF
+
+    !
+    ! 2 PFT has to be there, start of growing season must be allowed, 
+    !   and gdd has to be defined
+    !
+
+    DO i = 1, npts
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
+            ( gdd(i,j) .NE. undef )                           ) THEN
+
+          ! is critical gdd reached and is temperature increasing?
+          ! has enough time gone by since moisture minimum and is moisture increasing?
+
+          tl(i) = tlong_ref(i) - ZeroCelsius
+          gdd_crit(i) = pheno_crit%gdd(j,1) + tl(i)*pheno_crit%gdd(j,2) + &
+               tl(i)*tl(i)*pheno_crit%gdd(j,3)
+
+          IF ( ( gdd(i,j) .GE. gdd_crit(i) ) .AND. &
+               ( ( t2m_week(i) .GT. t2m_month(i) ) .OR. &
+               ( t2m_month(i) .GT. t_always )          ) .AND. &
+               ( ( ( time_hum_min(i,j) .GT. pheno_crit%hum_min_time(j) ) .AND. &
+               ( moiavail_week(i,j) .GT. moiavail_month(i,j) )            ) .OR. &
+               ( moiavail_month(i,j) .GE. moiavail_always )                         ) )  THEN
+             begin_leaves(i,j) = .TRUE.
+          ENDIF
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving moigdd'
+
+  END SUBROUTINE pheno_moigdd
+
+
+  !
+  ! ==============================================================================
+  ! Phenology: leaves are put on if a certain relationship between ncd since leaves were 
+  !            lost (number of chilling days) and gdd since midwinter (growing degree 
+  !            days) is fulfilled
+  !
+
+  SUBROUTINE pheno_ncdgdd (npts, j, PFTpresent, allow_initpheno, &
+       ncd_dormance, gdd_midwinter, &
+       t2m_month, t2m_week, begin_leaves)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                     :: npts
+    ! PFT index
+    INTEGER(i_std), INTENT(in)                               :: j
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
+    ! are we allowed to declare the beginning of the growing season?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
+    ! number of chilling days since leaves were lost
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: ncd_dormance
+    ! growing degree days since midwinter
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: gdd_midwinter
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
+    ! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
+
+    ! 0.2 output
+
+    ! signal to start putting leaves on
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves
+
+    ! 0.3 local
+
+    ! index
+    INTEGER(i_std)                                           :: i
+    ! critical gdd
+    REAL(r_std)                                              :: gdd_min
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering ncdgdd'
+
+    !
+    ! 1 Initializations
+    !
+
+    !
+    ! 1.1 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    ! 1.2 check the prescribed critical values
+    !
+
+    IF ( pheno_crit%ncdgdd_temp(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'ncdgdd: pheno_crit%ncdgdd_temp is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    ! 2 PFT has to be there and start of growing season must be allowed
+    !
+
+    DO i = 1, npts
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) .AND. &
+            ( gdd_midwinter(i,j) .NE. undef ) .AND. &
+            ( ncd_dormance(i,j) .NE. undef )                  ) THEN
+
+          ! critical gdd
+
+          gdd_min = ( 603. / exp(0.0091*ncd_dormance(i,j)) - 64. )
+
+          ! has the critical gdd been reached and are temperatures increasing?
+
+          IF ( ( gdd_midwinter(i,j) .GE. gdd_min ) .AND. &
+               ( t2m_week(i) .GT. t2m_month(i) ) ) THEN
+             begin_leaves(i,j) = .TRUE.
+             gdd_midwinter(i,j)=undef
+          ENDIF
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving ncdgdd'
+
+  END SUBROUTINE pheno_ncdgdd
+
+  !
+  ! ==============================================================================
+  ! Phenology: leaves are put on if ngd (number of growing days, defined as
+  !            days with t>-5 deg C) exceeds a critical value.
+  !
+
+  SUBROUTINE pheno_ngd (npts, j, PFTpresent, allow_initpheno, ngd, &
+       t2m_month, t2m_week, begin_leaves)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                     :: npts
+    ! PFT index
+    INTEGER(i_std), INTENT(in)                               :: j
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: PFTpresent
+    ! are we allowed to declare the beginning of the growing season?
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)               :: allow_initpheno
+    ! growing degree days
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: ngd
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_month
+    ! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                 :: t2m_week
+
+    ! 0.2 output
+
+    ! signal to start putting leaves on
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)              :: begin_leaves
+
+    ! 0.3 local
+
+    ! index
+    INTEGER(i_std)                                           :: i
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering ngd'
+
+    !
+    ! Initializations
+    !
+
+    !
+    ! 1.1 initialize output
+    !
+
+    begin_leaves(:,j) = .FALSE.
+
+    !
+    ! 1.2 check the prescribed critical value
+    !
+
+    IF ( pheno_crit%ngd(j) .EQ. undef ) THEN
+
+       WRITE(numout,*) 'ngd: pheno_crit%ngd is undefined for PFT',j
+       WRITE(numout,*) 'We stop.'
+       STOP
+
+    ENDIF
+
+    !
+    ! 2 PFT has to be there and start of growing season must be allowed
+    !
+
+    DO i = 1, npts
+
+       IF ( PFTpresent(i,j) .AND. allow_initpheno(i,j) ) THEN
+
+          ! is critical ngd reached and are temperatures increasing?
+
+          IF ( ( ngd(i,j) .GE. pheno_crit%ngd(j) ) .AND. &
+               ( t2m_week(i) .GT. t2m_month(i) )        ) THEN
+             begin_leaves(i,j) = .TRUE.
+          ENDIF
+
+       ENDIF        ! PFT there and start of growing season allowed
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving ngd'
+
+  END SUBROUTINE pheno_ngd
+
+END MODULE stomate_phenology
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_prescribe.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_prescribe.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_prescribe.f90	(revision 55)
@@ -0,0 +1,295 @@
+! Initialize density of individuals and crown area to some reasonable value
+!   if the DGVM is not (yet) activated.
+! Prescribe density of individuals and crown area for agricultural PFTs.
+! At first call, if the DGVM is not (yet) activated, impose some biomass if zero
+!   for a prescribed PFT. Initialize leaf age classes.
+! At first call, if the DGVM is not (yet) activated, declare PFT present if its 
+!   prescribed vegetation cover is above 0
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_prescribe.f90,v 1.10 2009/01/07 12:56:10 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_prescribe
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC prescribe,prescribe_clear
+
+    ! first call
+    LOGICAL, SAVE                                              :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE prescribe_clear
+    firstcall=.TRUE.
+  END SUBROUTINE prescribe_clear
+ 
+ SUBROUTINE prescribe (npts, &
+                        veget_max, PFTpresent, everywhere, when_growthinit, &
+                        biomass, leaf_frac, ind, cn_ind)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                        :: npts
+
+    ! 0.2 modified fields
+
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max
+    ! PFT present
+    LOGICAL, DIMENSION(npts,nvm), INTENT(inout)               :: PFTpresent
+    ! is the PFT everywhere in the grid box or very localized (after its introduction)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: everywhere
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: when_growthinit
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: biomass
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
+    ! density of individuals (1/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: ind
+    ! crown area of individuals (m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: cn_ind
+
+    ! 0.3 output
+
+
+    ! 0.4 local
+
+    ! generic tree crown area (m**2)
+    REAL(r_std), PARAMETER                                      :: cn_tree = 4.
+    ! stem diameter (m)
+    REAL(r_std), DIMENSION(npts)                                :: dia
+    ! woodmass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: woodmass
+    ! woodmass of an individual (gC)
+    REAL(r_std), DIMENSION(npts)                                :: woodmass_ind
+    ! index
+    INTEGER(i_std)                                             :: i,j
+
+    ! =========================================================================
+
+    DO j = 2,nvm
+
+      ! only when the DGVM is not activated or agricultural PFT.
+
+      IF ( ( .NOT. control%ok_dgvm ) .OR. ( .NOT. natural(j) ) ) THEN
+
+        !
+        ! 1 crown area
+        !
+
+        cn_ind(:,j) = 0.0
+
+        IF ( tree(j) ) THEN
+
+          !
+          ! 1.1 trees
+          !
+
+          dia(:) = 0.0
+
+          DO i = 1, npts
+
+            IF ( veget_max(i,j) .GT. zero ) THEN
+
+              ! 1.1.1 calculate total wood mass
+
+              woodmass(i) = (biomass(i,j,isapabove) + biomass(i,j,isapbelow) + &
+                   biomass(i,j,iheartabove) + biomass(i,j,iheartbelow)) * veget_max(i,j)  
+
+              IF ( woodmass(i) .GT. min_stomate ) THEN
+
+                ! 1.1.2 calculate critical density of individuals
+
+                ind(i,j) = woodmass(i) / &
+                           ( pipe_density*pi/4.*pipe_tune2 * maxdia(j)**(2.+pipe_tune3) )
+
+                ! 1.1.3 individual biomass corresponding to this critical density of individuals
+
+                woodmass_ind(i) = woodmass(i) / ind(i,j)
+
+                ! 1.1.4 stem diameter
+
+                dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** &
+                         ( un / ( 2. + pipe_tune3 ) )
+
+                ! 1.1.5 crown area, provisional
+
+                cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
+
+                ! 1.1.6 do we have to recalculate the crown area?
+
+                IF ( cn_ind(i,j) * ind(i,j) .GT. 1.002* veget_max(i,j) ) THEN
+
+                  ind(i,j) = veget_max(i,j) / cn_ind(i,j)
+
+                ELSE
+
+                  ind(i,j) = ( veget_max(i,j) / &
+                               ( pipe_tune1 * (woodmass(i)/(pipe_density*pi/4.*pipe_tune2))**(1.6/(2.+pipe_tune3)) ) ) &
+                             ** (1./(1.-(1.6/(2.+pipe_tune3))))
+
+                  woodmass_ind(i) = woodmass(i) / ind(i,j)
+
+                  dia(i) = ( woodmass_ind(i) / ( pipe_density * pi/4. * pipe_tune2 ) ) ** &
+                           ( un / ( 2. + pipe_tune3 ) )
+
+                  ! final crown area
+                  cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
+
+                ENDIF
+
+              ELSE
+
+                ! woodmass = 0 => impose some value
+
+                dia(:) = maxdia(j)
+
+                cn_ind(i,j) = pipe_tune1 * MIN( maxdia(j), dia(i) ) ** 1.6
+
+              ENDIF
+
+            ENDIF    ! veget_max .GT. 0.
+
+          ENDDO      ! loop over grid points
+
+        ELSE
+
+          !
+          ! 1.2 grasses: always 1m**2
+          !
+
+          WHERE ( veget_max(:,j) .GT. 0.0 )
+            cn_ind(:,j) = un
+          ENDWHERE
+
+        ENDIF   ! tree/grass?
+
+        !
+        ! 2 density of individuals
+        !
+
+        WHERE ( veget_max(:,j) .GT. 0.0 )
+
+          ind(:,j) = veget_max(:,j) / cn_ind(:,j)
+
+        ELSEWHERE
+
+          ind(:,j) = 0.0
+
+        ENDWHERE
+
+      ENDIF     ! not natural or DGVM not activated?
+
+    ENDDO       ! loop over PFTs
+
+    !
+    ! 4 first call
+    !
+
+    IF ( firstcall ) THEN
+
+      WRITE(numout,*) 'prescribe:'
+
+      ! impose some biomass if zero and PFT prescribed
+
+      WRITE(numout,*) '   > Imposing initial biomass for prescribed trees, '// &
+                      'initial reserve mass for prescribed grasses.'
+      WRITE(numout,*) '   > Declaring prescribed PFTs present.'
+
+      DO j = 2,nvm
+        DO i = 1, npts
+
+          ! is vegetation static or PFT agricultural?
+
+          IF ( ( .NOT. control%ok_dgvm ) .OR. &
+               ( ( .NOT. natural(j) ) .AND. ( veget_max(i,j) .GT. min_stomate ) ) ) THEN
+
+            !
+            ! 4.1 trees 
+            !
+
+            IF ( tree(j) .AND. &
+                 ( veget_max(i,j) .GT. min_stomate ) .AND. &
+                 ( SUM( biomass(i,j,:) ) .LE. min_stomate ) ) THEN
+
+               IF (veget_max(i,j) .GT. min_stomate) THEN
+                  biomass(i,j,:) = (40. * bm_sapl(j,:) * ind(i,j)) / veget_max(i,j)
+               ELSE
+                  biomass(i,j,:) = zero
+               ENDIF
+
+              ! set leaf age classes
+              leaf_frac(i,j,:) = zero
+              leaf_frac(i,j,1) = un
+
+              ! set time since last beginning of growing season
+              when_growthinit(i,j) = large_value
+
+              ! seasonal trees: no leaves at beginning
+
+              IF ( pheno_crit%pheno_model(j) .NE. 'none' ) THEN
+
+                biomass(i,j,ileaf) = zero
+                leaf_frac(i,j,1) = zero
+
+              ENDIF
+
+            ENDIF
+
+            !
+            ! 4.2 grasses
+            !
+
+            IF ( ( .NOT. tree(j) ) .AND. &
+                 ( veget_max(i,j) .GT. min_stomate ) .AND. &
+                 ( SUM( biomass(i,j,:) ) .LE. min_stomate ) ) THEN
+
+              biomass(i,j,icarbres) = bm_sapl(j,icarbres) * ind(i,j) / veget_max(i,j)
+
+              ! set leaf age classes
+              leaf_frac(i,j,:) = zero
+              leaf_frac(i,j,1) = un
+
+              ! set time since last beginning of growing season
+              when_growthinit(i,j) = large_value
+
+            ENDIF
+
+            !
+            ! 4.3 declare PFT present everywhere in that grid box
+            !
+
+            IF ( veget_max(i,j) .GT. min_stomate ) THEN
+              PFTpresent(i,j) = .TRUE.
+              everywhere(i,j) = un
+            ENDIF
+
+          ENDIF   ! not control%ok_dgvm  or agricultural
+
+        ENDDO
+      ENDDO
+
+      firstcall = .FALSE.
+
+    ENDIF
+
+  END SUBROUTINE prescribe
+
+END MODULE stomate_prescribe
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_resp.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_resp.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_resp.f90	(revision 55)
@@ -0,0 +1,242 @@
+!$Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_resp.f90,v 1.7 2009/01/06 17:18:32 ssipsl Exp $
+!IPSL (2006)
+! This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+ 
+  !  calculate maintenance respiration on an hourly time step (NV 14/5/2002)
+MODULE stomate_resp
+  ! modules used:
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC maint_respiration,maint_respiration_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE maint_respiration_clear
+    firstcall=.TRUE.
+  END SUBROUTINE maint_respiration_clear
+
+  SUBROUTINE maint_respiration ( npts,dt,lai, t2m,tlong_ref,stempdiag,height,veget_max,&
+       rprof,biomass,resp_maint_part_radia)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                        :: npts
+    ! time step (seconds)
+    REAL(r_std), INTENT(in)                                     :: dt
+    ! 2 m air temperature (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m
+    ! 2 m air temperature (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref
+    ! Soil temperature
+    REAL(r_std),DIMENSION (npts,nbdl), INTENT (in)              :: stempdiag
+    ! height of vegetation (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: height
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on nat/agri ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max
+    ! root depth (m)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: rprof
+    ! biomass (gC/m**2)
+    REAL(r_std),DIMENSION(npts,nvm,nparts),INTENT(in)          :: biomass 
+    ! 0.2 modified fields
+
+
+    ! 0.3 output
+
+    ! maintenance respiration of different parts (gC/dt/m**2 of total ground)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)             :: resp_maint_part_radia
+    ! 0.4 local
+
+    ! leaf area index
+    REAL(r_std), DIMENSION(npts,nvm)                           :: lai
+    ! soil levels (m)
+    REAL(r_std), SAVE, DIMENSION(0:nbdl)                        :: z_soil
+    ! root temperature (convolution of root and soil temperature profiles)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: t_root
+    ! maintenance respiration coefficients at 0 deg C (g/g d**-1)
+    REAL(r_std), DIMENSION(npts,nvm,nparts)                    :: coeff_maint
+    ! temperature which is pertinent for maintenance respiration (K)
+    REAL(r_std), DIMENSION(npts,nparts)                         :: t_maint
+    ! integration constant for root profile
+    REAL(r_std), DIMENSION(npts)                                :: rpc
+    ! temperature which is pertinent for maintenance respiration (K)
+    REAL(r_std), DIMENSION(npts,nparts)                         :: t_maint_radia
+    ! long term annual mean temperature, C
+    REAL(r_std), DIMENSION(npts)                                :: tl
+    ! slope of maintenance respiration coefficient (1/K)
+    REAL(r_std), DIMENSION(npts)                                :: slope
+    ! Index
+    INTEGER(i_std)                                              :: i,j,k,l,m
+
+    !
+    !
+    ! 2 define maintenance respiration coefficients
+    !
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering respiration'
+    !
+    ! 1 Initializations
+    !
+    IF ( firstcall ) THEN
+
+       ! 1.1.1 soil levels
+
+       z_soil(0) = zero
+       z_soil(1:nbdl) = diaglev(1:nbdl)
+
+       ! 1.1.2 messages
+
+       WRITE(numout,*) 'respiration:'
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+
+    !
+    ! 1 do initialisation
+    !
+
+
+    DO j = 2,nvm
+
+       ! 1.3.1 rpc is an integration constant such that the integral of the root profile is un
+       rpc(:) = un / ( un - EXP( -z_soil(nbdl) / rprof(:,j) ) )
+
+       ! 1.3.2 integrate over the nbdl levels
+
+       t_root(:,j) = 0.0
+
+       DO l = 1, nbdl
+
+          t_root(:,j) = &
+               t_root(:,j) + stempdiag(:,l) * rpc(:) * &
+               ( EXP( -z_soil(l-1)/rprof(:,j) ) - EXP( -z_soil(l)/rprof(:,j) ) )
+
+       ENDDO
+
+    ENDDO
+
+    DO j = 2,nvm
+
+       !
+       ! 2.1 temperature which is taken for the plant part we are talking about
+       !
+
+       ! 2.1.1 parts above the ground
+
+       t_maint_radia(:,ileaf) = t2m(:)
+       t_maint_radia(:,isapabove) = t2m(:)
+       t_maint_radia(:,ifruit) = t2m(:)
+
+       ! 2.1.2 parts below the ground
+
+       t_maint_radia(:,isapbelow) = t_root(:,j)
+       t_maint_radia(:,iroot) = t_root(:,j)
+
+       ! 2.1.3 heartwood: does not respire. Any temperature
+
+       t_maint_radia(:,iheartbelow) = t_root(:,j)
+       t_maint_radia(:,iheartabove) = t2m(:)
+
+       ! 2.1.4 reserve: above the ground for trees, below for grasses
+
+       IF ( tree(j) ) THEN
+          t_maint_radia(:,icarbres) = t2m(:)
+       ELSE
+          t_maint_radia(:,icarbres) = t_root(:,j)
+       ENDIF
+
+       !
+       ! 2.2 calculate coefficient
+       !
+
+       tl(:) = tlong_ref(:) - ZeroCelsius
+       slope(:) = maint_resp_slope(j,1) + tl(:) * maint_resp_slope(j,2) + &
+            tl(:)*tl(:) * maint_resp_slope(j,3)
+
+       DO k = 1, nparts
+
+          coeff_maint(:,j,k) = &
+               MAX( (coeff_maint_zero(j,k)*dt/one_day) * &
+               ( un + slope(:) * (t_maint_radia(:,k)-ZeroCelsius) ), 0._r_std )
+
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 3 calculate maintenance respiration.
+    !
+
+
+    lai(:,ibare_sechiba) = zero
+    resp_maint_part_radia(:,ibare_sechiba,:) = zero
+    !
+    DO j = 2,nvm
+       !
+       ! 3.1 maintenance respiration of the different plant parts
+       !
+       lai(:,j) = biomass(:,j,ileaf) * sla(j)
+
+       DO k = 1, nparts
+
+          IF ( k .EQ. ileaf ) THEN
+
+             ! Leaves: respiration depends on leaf mass AND LAI.
+!!$                WHERE ( (biomass(:,j,ileaf) > min_stomate) .AND. (lai(:,j) > 0.0) .AND. (lai(:,j) < val_exp) )
+!!$                resp_maint_part_radia(:,j,k) = coeff_maint(:,j,k) * biomass(:,j,k) * &
+!!$                        ( .3*lai(:,j) + 1.4*(1.-exp(-.5*lai(:,j))) ) / lai(:,j)
+!!$             ELSEWHERE
+!!$                resp_maint_part_radia(:,j,k) = 0.0
+!!$             ENDWHERE
+             DO i = 1, npts
+                IF ( (biomass(i,j,ileaf) > min_stomate) .AND. (lai(i,j) > min_stomate) ) THEN
+!!$                         IF (lai(i,j) < 100._r_std) THEN
+!!$                            resp_maint_part_radia(i,j,k) = coeff_maint(i,j,k) * biomass(i,j,k) * &
+!!$                                 ( .3*lai(i,j) + 1.4*(1.-exp(-.5*lai(i,j))) ) / lai(i,j)
+!!$                         ELSE
+!!$                            resp_maint_part_radia(i,j,k) = coeff_maint(i,j,k) * biomass(i,j,k) * &
+!!$                                 ( .3*lai(i,j) + 1.4 ) / lai(i,j)
+!!$                         ENDIF
+                   resp_maint_part_radia(i,j,k) = coeff_maint(i,j,k) * biomass(i,j,k) * &
+                        ( .3*lai(i,j) + 1.4*(1.-exp(-.5*lai(i,j))) ) / lai(i,j)
+                ELSE
+                   resp_maint_part_radia(i,j,k) = zero
+                ENDIF
+             ENDDO
+          ELSE
+
+             resp_maint_part_radia(:,j,k) = coeff_maint(:,j,k) * biomass(:,j,k)
+
+          ENDIF
+
+       ENDDO
+
+       !
+       ! 3.2 Total maintenance respiration of the plant
+       !     VPP killer:
+       !     resp_maint(:,j) = SUM( resp_maint_part(:,:), DIM=2 )
+       !
+
+    ENDDO
+
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving respiration'
+
+  END SUBROUTINE maint_respiration
+
+END MODULE stomate_resp
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_season.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_season.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_season.f90	(revision 55)
@@ -0,0 +1,997 @@
+! Calculate long-term meteorological parameters from daily temperatures
+! and precipitations (essentially for phenology)
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_season.f90,v 1.15 2010/04/06 16:06:34 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_season
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC season,season_clear
+
+  ! first call
+  LOGICAL, SAVE                                          :: firstcall = .TRUE.
+
+CONTAINS
+
+
+  SUBROUTINE season_clear
+    firstcall=.TRUE.
+  END SUBROUTINE season_clear
+
+  SUBROUTINE season (npts, dt, EndOfYear, veget, veget_max, &
+       moiavail_daily, t2m_daily, tsoil_daily, soilhum_daily, &
+       precip_daily, npp_daily, biomass, turnover_daily, gpp_daily, when_growthinit, &
+       maxmoiavail_lastyear, maxmoiavail_thisyear, &
+       minmoiavail_lastyear, minmoiavail_thisyear, &
+       maxgppweek_lastyear, maxgppweek_thisyear, &
+       gdd0_lastyear, gdd0_thisyear, &
+       precip_lastyear, precip_thisyear, &
+       lm_lastyearmax, lm_thisyearmax, &
+       maxfpc_lastyear, maxfpc_thisyear, &
+       moiavail_month, moiavail_week, t2m_longterm, tlong_ref, t2m_month, t2m_week, &
+       tsoil_month, soilhum_month, &
+       npp_longterm, turnover_longterm, gpp_week, &
+       gdd_m5_dormance, gdd_midwinter, ncd_dormance, ngd_minus5, time_lowgpp, &
+       time_hum_min, hum_min_dormance, herbivores)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                    :: npts
+    ! time step in days
+    REAL(r_std), INTENT(in)                                 :: dt
+    ! update yearly variables?
+    LOGICAL, INTENT(in)                                    :: EndOfYear
+    ! coverage fraction of a PFT. Here: fraction of total ground.
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget
+    ! "maximal" coverage fraction of a PFT (for LAI -> infinity)
+    ! Here: fraction of total ground.
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: veget_max
+    ! Daily moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: moiavail_daily
+    ! Daily 2 meter temperature (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                :: t2m_daily
+    ! Daily soil temperature (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)           :: tsoil_daily
+    ! Daily soil humidity
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(in)           :: soilhum_daily
+    ! Daily mean precipitation (mm/day)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                :: precip_daily
+    ! daily net primary productivity (gC/m**2/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: npp_daily
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)    :: biomass
+    ! Turnover rates (gC/m**2/day)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(in)    :: turnover_daily
+    ! daily gross primary productivity (Here: gC/(m**2 of total ground)/day)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: gpp_daily
+    ! how many days ago was the beginning of the growing season
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)           :: when_growthinit
+
+    ! 0.2 modified fields
+
+    ! last year's maximum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxmoiavail_lastyear
+    ! this year's maximum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxmoiavail_thisyear
+    ! last year's minimum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: minmoiavail_lastyear
+    ! this year's minimum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: minmoiavail_thisyear
+    ! last year's maximum weekly GPP
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxgppweek_lastyear
+    ! this year's maximum weekly GPP
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxgppweek_thisyear
+    ! last year's annual GDD0
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: gdd0_lastyear
+    ! this year's annual GDD0
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: gdd0_thisyear
+    ! last year's annual precipitation (mm/year)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: precip_lastyear
+    ! this year's annual precipitation (mm/year)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: precip_thisyear
+    ! last year's maximum leaf mass, for each PFT (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: lm_lastyearmax
+    ! this year's maximum leaf mass, for each PFT (gC/m**2)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: lm_thisyearmax
+    ! last year's maximum fpc for each PFT, on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxfpc_lastyear
+    ! this year's maximum fpc for each PFT, on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: maxfpc_thisyear
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: moiavail_month
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: moiavail_week
+    ! "long term" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: t2m_longterm
+    ! "long term" refernce 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: tlong_ref
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: t2m_month
+    ! "weekly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(inout)             :: t2m_week
+    ! "monthly" soil temperatures (K)
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout)        :: tsoil_month
+    ! "monthly" soil humidity
+    REAL(r_std), DIMENSION(npts,nbdl), INTENT(inout)        :: soilhum_month
+    ! "long term" net primary productivity (gC/m**2/year)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: npp_longterm
+    ! "long term" turnover rate (gC/m**2/year)
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout) :: turnover_longterm
+    ! "weekly" GPP (gC/day/(m**2 covered)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: gpp_week
+    ! growing degree days, threshold -5 deg. C
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: gdd_m5_dormance
+    ! growing degree days since midwinter
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: gdd_midwinter
+    ! number of chilling days since leaves were lost
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: ncd_dormance
+    ! number of growing days
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: ngd_minus5
+    ! duration of dormance (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: time_lowgpp
+    ! time elapsed since strongest moisture availability (d)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: time_hum_min
+    ! minimum moisture during dormance
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)        :: hum_min_dormance
+
+    ! 0.3 output (diagnostic)
+
+    ! time constant of probability of a leaf to be eaten by a herbivore (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)          :: herbivores
+
+    ! 0.4 local
+
+    ! indices
+    INTEGER(i_std)                                          :: j
+    ! rapport maximal GPP/GGP_max pour dormance
+    REAL(r_std), PARAMETER                                  :: gppfrac_dormance = 0.2
+!
+!NVADD
+     ! minimum gpp considered as not "lowgpp"
+    REAL(r_std), PARAMETER                                  :: min_gpp_allowed = 0.3
+     ! tau (year) for "climatologic variables
+    REAL(r_std), PARAMETER                                  :: tau_climatology = 20
+!ENDNVADD
+    ! maximum ncd (d) (to avoid floating point underflows)
+    REAL(r_std)                                             :: ncd_max 
+    ! parameters for herbivore activity
+    REAL(r_std), PARAMETER                                  :: hvc1 = 0.019
+    REAL(r_std), PARAMETER                                  :: hvc2 = 1.38
+    REAL(r_std), PARAMETER                                  :: leaf_frac=.33
+    ! sum of natural fpcs
+    REAL(r_std), DIMENSION(npts)                            :: sumfpc_nat
+    ! weights
+    REAL(r_std), DIMENSION(npts)                            :: weighttot
+    ! natural long-term leaf NPP ( gC/m**2/year)
+    REAL(r_std), DIMENSION(npts)                            :: nlflong_nat
+    ! residence time of green tissue (years)
+    REAL(r_std), DIMENSION(npts)                            :: green_age
+    ! herbivore consumption (gC/m**2/day)
+    REAL(r_std), DIMENSION(npts)                            :: consumption
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering season'
+
+    !
+    ! 1 Initializations
+    !
+    ncd_max = 3. * one_year
+
+    IF ( firstcall ) THEN
+
+       !
+       ! 1.1 messages
+       !
+
+       IF ( bavard .GE. 1 ) THEN
+
+          WRITE(numout,*) 'season: '
+
+          WRITE(numout,*) '   > rapport maximal GPP/GGP_max pour dormance: ',gppfrac_dormance
+
+          WRITE(numout,*) '   > maximum possible ncd (d): ',ncd_max
+
+          WRITE(numout,*) '   > herbivore consumption C (gC/m2/day) as a function of NPP (gC/m2/d):'
+          WRITE(numout,*) '     C=',hvc1,' * NPP^',hvc2
+          WRITE(numout,*) '   > for herbivores, suppose that ',leaf_frac*100., &
+               '% of NPP is allocated to leaves'
+
+
+       ENDIF
+
+       !
+       ! 1.2 Check whether longer-term meteorological parameters are initialized
+       !     to zero
+       !
+
+       ! 1.2.1 moisture availabilities
+
+       ! 1.2.1.1 "monthly"
+!MM PAS PARALLELISE!!
+       IF ( ABS( SUM( moiavail_month(:,2:nvm) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them it today's moisture availability
+          WRITE(numout,*) 'Warning! We have to initialize the ''monthly'' moisture availabilities.'
+          moiavail_month(:,:) = moiavail_daily(:,:)
+
+       ENDIF
+
+       ! 1.2.1.2 "weekly"
+
+       IF ( ABS( SUM( moiavail_week(:,2:nvm) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them it today's moisture availability
+          WRITE(numout,*) 'Warning! We have to initialize the ''weekly'' moisture availabilities.'
+          moiavail_week(:,:) = moiavail_daily(:,:)
+
+       ENDIF
+
+       ! 1.2.2 2-meter temperatures
+
+       ! 1.2.2.1 "long term"
+
+       IF ( ABS( SUM( t2m_longterm(:) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them to today's temperature
+          WRITE(numout,*) 'Warning! We have to initialize the ''long term'' 2m temperatures.'
+          t2m_longterm(:) = t2m_daily(:)
+
+       ENDIF
+
+       ! 1.2.2.2 "monthly"
+
+       IF ( ABS( SUM( t2m_month(:) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them to today's temperature
+          WRITE(numout,*) 'Warning! We have to initialize the ''monthly'' 2m temperatures.'
+          t2m_month(:) = t2m_daily(:)
+
+       ENDIF
+
+       ! 1.2.2.3 "weekly"
+
+       IF ( ABS( SUM( t2m_week(:) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them to today's temperature
+          WRITE(numout,*) 'Warning! We have to initialize the ''weekly'' 2m temperatures.'
+          t2m_week(:) = t2m_daily(:)
+
+       ENDIF
+
+       ! 1.2.3 "monthly" soil temperatures
+!MM PAS PARALLELISE!!
+       IF ( ABS( SUM( tsoil_month(:,:) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them to today's temperature
+          WRITE(numout,*) 'Warning!'// &
+               ' We have to initialize the ''monthly'' soil temperatures.'
+          tsoil_month(:,:) = tsoil_daily(:,:)
+
+       ENDIF
+
+       ! 1.2.4 "monthly" soil humidity
+       IF ( ABS( SUM( soilhum_month(:,:) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them to today's humidity
+          WRITE(numout,*) 'Warning!'// &
+               ' We have to initialize the ''monthly'' soil humidity.'
+          soilhum_month(:,:) = soilhum_daily(:,:)
+
+       ENDIF
+
+       ! 1.2.5 growing degree days, threshold -5 deg C
+       IF ( ABS( SUM( gdd_m5_dormance(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Growing degree days (-5 deg) are initialized to ''undef''.'
+          gdd_m5_dormance(:,:) = undef
+       ENDIF
+
+       ! 1.2.6 growing degree days since midwinter
+       IF ( ABS( SUM( gdd_midwinter(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Growing degree days since midwinter' // &
+               ' are initialized to ''undef''.'
+          gdd_midwinter(:,:) = undef
+       ENDIF
+
+       ! 1.2.7 number of chilling days since leaves were lost
+       IF ( ABS( SUM( ncd_dormance(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Number of chilling days is initialized to ''undef''.'
+          ncd_dormance(:,:) = undef
+       ENDIF
+
+       ! 1.2.8 number of growing days, threshold -5 deg C
+       IF ( ABS( SUM( ngd_minus5(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Number of growing days (-5 deg) is initialized to 0.'
+       ENDIF
+
+       ! 1.2.9 "long term" npp
+       IF ( ABS( SUM( npp_longterm(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Long term NPP is initialized to 0.'
+       ENDIF
+
+       ! 1.2.10 "long term" turnover
+       IF ( ABS( SUM( turnover_longterm(:,2:nvm,:) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Long term turnover is initialized to 0.'
+       ENDIF
+
+       ! 1.2.11 "weekly" GPP
+       IF ( ABS( SUM( gpp_week(:,2:nvm) ) ) .LT. min_stomate ) THEN
+          WRITE(numout,*) 'Warning! Weekly GPP is initialized to 0.'
+       ENDIF
+
+       ! 1.2.12 minimum moisture availabilities
+       IF ( ABS( SUM( minmoiavail_thisyear(:,2:nvm) ) ) .LT. min_stomate ) THEN
+
+          ! in this case, set them to a very high value
+          WRITE(numout,*) 'Warning! We have to initialize this year''s minimum '// &
+               'moisture availabilities.'
+          minmoiavail_thisyear(:,:) = large_value
+
+       ENDIF
+
+       !
+       ! 1.3 reset flag
+       !
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 2 moisture availabilities
+    !
+
+    !
+    ! 2.1 "monthly"
+    !
+
+    moiavail_month = ( moiavail_month * ( pheno_crit%tau_hum_month - dt ) + &
+         moiavail_daily * dt ) / pheno_crit%tau_hum_month
+
+    DO j = 2,nvm
+       WHERE ( ABS(moiavail_month(:,j)) .LT. EPSILON(zero) )
+          moiavail_month(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 2.2 "weekly"
+    !
+
+    moiavail_week = ( moiavail_week * ( pheno_crit%tau_hum_week - dt ) + &
+         moiavail_daily * dt ) / pheno_crit%tau_hum_week
+
+    DO j = 2,nvm
+       WHERE ( ABS(moiavail_week(:,j)) .LT. EPSILON(zero) ) 
+          moiavail_week(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 3 2-meter temperatures
+    !
+
+    !
+    ! 3.1 "long term"
+    !
+
+    t2m_longterm = ( t2m_longterm * ( pheno_crit%tau_longterm - dt ) + &
+         t2m_daily * dt ) / pheno_crit%tau_longterm
+
+    WHERE ( ABS(t2m_longterm(:)) .LT. EPSILON(zero) ) 
+       t2m_longterm(:) = zero
+    ENDWHERE
+
+    CALL histwrite (hist_id_stomate, 'T2M_LONGTERM', itime, &
+         t2m_longterm, npts, hori_index)
+    !
+    ! 3.2 "long term reference"
+    !      This temperature is used for recalculating PFT-specific parameters such as
+    !      critical photosynthesis temperatures of critical GDDs for phenology. This
+    !      means that if the reference temperature varies, the PFTs adapt to them.
+    !      Therefore the reference temperature can vary only if the vegetation is not
+    !      static.
+    !
+
+!!$    IF (control%ok_dgvm) THEN
+    tlong_ref(:) = MAX( tlong_ref_min, MIN( tlong_ref_max, t2m_longterm(:) ) )
+!!$    ENDIF
+    !
+    ! 3.3 "monthly"
+    !
+
+    t2m_month = ( t2m_month * ( pheno_crit%tau_t2m_month - dt ) + &
+         t2m_daily * dt ) / pheno_crit%tau_t2m_month
+
+    WHERE ( ABS(t2m_month(:)) .LT. EPSILON(zero) )
+       t2m_month(:) = zero
+    ENDWHERE
+
+    !
+    ! 3.4 "weekly"
+    !
+
+    t2m_week = ( t2m_week * ( pheno_crit%tau_t2m_week - dt ) + &
+         t2m_daily * dt ) / pheno_crit%tau_t2m_week
+
+    WHERE ( ABS(t2m_week(:)) .LT. EPSILON(zero) )
+       t2m_week(:) = zero
+    ENDWHERE
+
+    !
+    ! 4 ''monthly'' soil temperatures
+    !
+
+    tsoil_month = ( tsoil_month * ( pheno_crit%tau_tsoil_month - dt ) + &
+         tsoil_daily(:,:) * dt ) / pheno_crit%tau_tsoil_month
+
+    WHERE ( ABS(tsoil_month(:,:)) .LT. EPSILON(zero) )
+       tsoil_month(:,:) = zero
+    ENDWHERE
+
+    !
+    ! 5 ''monthly'' soil humidity
+    !
+
+    soilhum_month = ( soilhum_month * ( pheno_crit%tau_soilhum_month - dt ) + &
+         soilhum_daily * dt ) / pheno_crit%tau_soilhum_month
+
+    WHERE ( ABS(soilhum_month(:,:)) .LT. EPSILON(zero) )
+       soilhum_month(:,:) = zero
+    ENDWHERE
+
+    !
+    ! 6 dormance (d)
+    !   when gpp is low, increase dormance time. Otherwise, set it to zero.
+    !   NV: special case (3rd condition): plant is accumulating carbohydrates
+    !         and does never use them. In this case, we allow the plant to
+    !         detect a beginning of the growing season by declaring it dormant
+    !
+!NVMODIF
+    DO j = 2,nvm
+       WHERE ( ( gpp_week(:,j) .LT. min_gpp_allowed ) .OR. & 
+            ( gpp_week(:,j) .LT. gppfrac_dormance * maxgppweek_lastyear(:,j) ) .OR. &
+            ( ( when_growthinit(:,j) .GT. 2.*one_year ) .AND. &
+            ( biomass(:,j,icarbres) .GT. biomass(:,j,ileaf)*4. ) ) )
+!       WHERE ( ( gpp_week(:,j) .EQ. zero ) .OR. & 
+!            ( gpp_week(:,j) .LT. gppfrac_dormance * maxgppweek_lastyear(:,j) ) .OR. &
+!            ( ( when_growthinit(:,j) .GT. 2.*one_year ) .AND. &
+!            ( biomass(:,j,icarbres) .GT. biomass(:,j,ileaf)*4. ) ) )
+          
+          time_lowgpp(:,j) = time_lowgpp(:,j) + dt
+          
+       ELSEWHERE
+          
+          time_lowgpp(:,j) = zero
+
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 7 growing degree days, threshold -5 deg C
+    !
+
+    DO j = 2,nvm
+
+       ! only for PFTs for which critical gdd is defined
+       ! gdd_m5_dormance is set to 0 at the end of the growing season. It is set to undef
+       ! at the beginning of the growing season.
+
+       IF ( ALL(pheno_crit%gdd(j,:) .NE. undef) ) THEN
+
+          !
+          ! 7.1 set to zero if undef and no gpp
+          !
+
+          WHERE ( ( time_lowgpp(:,j) .GT. zero ) .AND. ( gdd_m5_dormance(:,j) .EQ. undef ) )
+
+             gdd_m5_dormance(:,j) = zero
+
+          ENDWHERE
+
+          !
+          ! 7.2 set to undef if there is gpp
+          !
+
+          WHERE ( time_lowgpp(:,j) .EQ. zero )
+
+             gdd_m5_dormance(:,j) = undef
+
+          ENDWHERE
+
+          !
+          ! 7.3 normal update where gdd_m5_dormance is defined
+          !
+
+          WHERE ( ( t2m_daily(:) .GT. (ZeroCelsius-5.) ) .AND. &
+               ( gdd_m5_dormance(:,j) .NE. undef )           )
+             gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) + &
+                  dt * ( t2m_daily(:) - (ZeroCelsius-5.) )
+          ENDWHERE
+
+          WHERE ( gdd_m5_dormance(:,j) .NE. undef ) 
+             gdd_m5_dormance(:,j) = gdd_m5_dormance(:,j) * &
+                  ( pheno_crit%tau_gdd - dt ) / pheno_crit%tau_gdd
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    DO j = 2,nvm
+       WHERE ( ABS(gdd_m5_dormance(:,j)) .LT. EPSILON(zero) )
+          gdd_m5_dormance(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 8 growing degree days since midwinter
+    !
+
+    DO j = 2,nvm
+
+       ! only for PFTs for which ncdgdd_crittemp is defined
+
+       IF ( pheno_crit%ncdgdd_temp(j) .NE. undef ) THEN
+
+          !
+          ! 8.1 set to 0 if undef and if we detect "midwinter"
+          !
+
+          WHERE ( ( gdd_midwinter(:,j) .EQ. undef ) .AND. &
+               ( t2m_month(:) .LT. t2m_week(:) ) .AND. &
+               ( t2m_month(:) .LT. t2m_longterm(:) )    )
+
+             gdd_midwinter(:,j) = zero
+
+          ENDWHERE
+
+          !
+          ! 8.2 set to undef if we detect "midsummer"
+          !
+
+          WHERE ( ( t2m_month(:) .GT. t2m_week(:) ) .AND. &
+               ( t2m_month(:) .GT. t2m_longterm(:) )    )
+
+             gdd_midwinter(:,j) = undef
+
+          ENDWHERE
+
+          !
+          ! 8.3 normal update
+          !
+
+          WHERE ( ( gdd_midwinter(:,j) .NE. undef ) .AND. &
+               ( t2m_daily(:) .GT. pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
+
+             gdd_midwinter(:,j) = &
+                  gdd_midwinter(:,j) + &
+                  dt * ( t2m_daily(:) - ( pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
+
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 9 number of chilling days since leaves were lost
+    !
+
+    DO j = 2,nvm
+
+       IF ( pheno_crit%ncdgdd_temp(j) .NE. undef ) THEN
+
+          !
+          ! 9.1 set to zero if undef and no gpp
+          !
+
+          WHERE ( ( time_lowgpp(:,j) .GT. zero ) .AND. ( ncd_dormance(:,j) .EQ. undef ) )
+
+             ncd_dormance(:,j) = zero
+
+          ENDWHERE
+
+          !
+          ! 9.2 set to undef if there is gpp
+          !
+
+          WHERE ( time_lowgpp(:,j) .EQ. zero )
+
+             ncd_dormance(:,j) = undef
+
+          ENDWHERE
+
+          !
+          ! 9.3 normal update where ncd_dormance is defined
+          !
+
+          WHERE ( ( ncd_dormance(:,j) .NE. undef ) .AND. &
+               ( t2m_daily(:) .LE. pheno_crit%ncdgdd_temp(j)+ZeroCelsius ) )
+
+             ncd_dormance(:,j) = MIN( ncd_dormance(:,j) + dt, ncd_max )
+
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 10 number of growing days, threshold -5 deg C
+    !
+
+    DO j = 2,nvm
+
+       !
+       ! 10.1 Where there is GPP, set ngd to 0
+       !      This means that we only take into account ngds when the leaves are off
+       !
+
+       WHERE ( time_lowgpp(:,j) .LT. min_stomate )
+          ngd_minus5(:,j) = zero
+       ENDWHERE
+
+       !
+       ! 10.2 normal update
+       !
+
+       WHERE ( t2m_daily(:) .GT. (ZeroCelsius-5.) )
+          ngd_minus5(:,j) = ngd_minus5(:,j) + dt
+       ENDWHERE
+
+       ngd_minus5(:,j) = ngd_minus5(:,j) * ( pheno_crit%tau_ngd - dt ) / pheno_crit%tau_ngd
+
+    ENDDO
+
+    DO j = 2,nvm
+       WHERE ( ABS(ngd_minus5(:,j)) .LT. EPSILON(zero) )
+          ngd_minus5(:,j) = zero
+       ENDWHERE
+    ENDDO
+    !
+    ! 11 minimum humidity since dormance began and time elapsed since this minimum
+    !
+
+    DO j = 2,nvm
+
+       IF ( pheno_crit%hum_min_time(j) .NE. undef ) THEN
+
+          !
+          ! 11.1 initialize if undef and no gpp
+          !
+
+          WHERE ( ( time_lowgpp(:,j) .GT. zero ) .AND. &
+               ( ( time_hum_min(:,j) .EQ. undef ) .OR. ( hum_min_dormance(:,j) .EQ. undef ) ) )
+
+             time_hum_min(:,j) = zero
+             hum_min_dormance(:,j) = moiavail_month(:,j)
+
+          ENDWHERE
+
+          !
+          ! 11.2 set to undef where there is gpp
+          !
+
+          WHERE ( time_lowgpp(:,j) .EQ. zero )
+
+             time_hum_min(:,j) = undef
+             hum_min_dormance(:,j) = undef
+
+          ENDWHERE
+
+          !
+          ! 11.3 normal update where time_hum_min and hum_min_dormance are defined
+          !
+
+          ! 11.3.1 increase time counter
+
+          WHERE ( ( time_hum_min(:,j) .NE. undef ) .AND. &
+               ( hum_min_dormance(:,j) .NE. undef )    )
+
+             time_hum_min(:,j) = time_hum_min(:,j) + dt
+
+          ENDWHERE
+
+          ! 11.3.2 set time to zero if minimum is reached
+
+          WHERE ( ( time_hum_min(:,j) .NE. undef ) .AND. &
+               ( hum_min_dormance(:,j) .NE. undef ) .AND. &
+               ( moiavail_month(:,j) .LE. hum_min_dormance(:,j) ) )
+
+             hum_min_dormance(:,j) = moiavail_month(:,j)
+             time_hum_min(:,j) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 12 "long term" NPP. npp_daily in gC/m**2/day, npp_longterm in gC/m**2/year.
+    !
+
+    npp_longterm = ( npp_longterm * ( pheno_crit%tau_longterm - dt ) + &
+         (npp_daily*one_year) * dt                          ) / &
+         pheno_crit%tau_longterm
+
+    DO j = 2,nvm
+       WHERE ( ABS(npp_longterm(:,j)) .LT. EPSILON(zero) )
+          npp_longterm(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 13 "long term" turnover rates, in gC/m**2/year.
+    !
+
+    turnover_longterm = ( turnover_longterm * ( pheno_crit%tau_longterm - dt ) + &
+         (turnover_daily*one_year) * dt                          ) / &
+         pheno_crit%tau_longterm
+
+    DO j = 2,nvm
+       WHERE ( ABS(turnover_longterm(:,j,:)) .LT. EPSILON(zero) )
+          turnover_longterm(:,j,:) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 14 "weekly" GPP, in gC/(m**2 covered)/day (!)
+    !    i.e. divide daily gpp (in gC/m**2 of total ground/day) by vegetation fraction
+    !    (m**2 covered/m**2 of total ground)
+    !
+
+    WHERE ( veget_max .GT. zero )
+
+       gpp_week = ( gpp_week * ( pheno_crit%tau_gpp_week - dt ) + &
+            gpp_daily * dt ) / pheno_crit%tau_gpp_week
+
+    ELSEWHERE
+
+       gpp_week = zero
+
+    ENDWHERE
+
+    DO j = 2,nvm
+       WHERE ( ABS(gpp_week(:,j)) .LT. EPSILON(zero) )
+          gpp_week(:,j) = zero
+       ENDWHERE
+    ENDDO
+
+    !
+    ! 15 maximum and minimum moisture availabilities
+    !
+
+    WHERE ( moiavail_daily .GT. maxmoiavail_thisyear )
+       maxmoiavail_thisyear = moiavail_daily
+    ENDWHERE
+
+    WHERE ( moiavail_daily .LT. minmoiavail_thisyear )
+       minmoiavail_thisyear = moiavail_daily
+    ENDWHERE
+
+    !
+    ! 16 annual maximum weekly GPP
+    !
+
+    WHERE ( gpp_week .GT. maxgppweek_thisyear )
+       maxgppweek_thisyear = gpp_week
+    ENDWHERE
+
+    !
+    ! 17 annual GDD0
+    !
+
+    WHERE ( t2m_daily .GT. ZeroCelsius )
+       gdd0_thisyear = gdd0_thisyear + dt * ( t2m_daily - ZeroCelsius )
+    ENDWHERE
+
+    !
+    ! 18 annual precipitation
+    !
+
+    precip_thisyear = precip_thisyear + dt * precip_daily
+
+    !
+    ! 19 annual maximum leaf mass
+    !    If STOMATE is not activated, this corresponds to the maximum possible 
+    !      LAI of the PFT
+    !
+
+    IF ( control%ok_stomate ) THEN
+
+       DO j = 2,nvm
+          WHERE ( biomass(:,j,ileaf) .GT. lm_thisyearmax(:,j) )
+             lm_thisyearmax(:,j) = biomass(:,j,ileaf)
+          ENDWHERE
+       ENDDO
+
+    ELSE
+
+       DO j = 2,nvm
+          lm_thisyearmax(:,j) = lai_max(j)  / sla(j)
+       ENDDO
+
+    ENDIF
+
+    !
+    ! 20 annual maximum fpc for each PFT
+    !    "veget" is defined as fraction of total ground. Therefore, maxfpc_thisyear has
+    !    the same unit.
+    !
+
+    WHERE ( veget(:,:) .GT. maxfpc_thisyear(:,:) )
+       maxfpc_thisyear(:,:) = veget(:,:)
+    ENDWHERE
+
+    !
+    ! 21 Every year, replace last year's maximum and minimum moisture availability,
+    !    annual GDD0, annual precipitation, annual max weekly GPP, and maximum leaf mass
+
+    IF ( EndOfYear ) THEN
+
+       !
+       ! 21.1 replace old values
+       !
+!NVMODIF
+      maxmoiavail_lastyear(:,:) = (maxmoiavail_lastyear(:,:)*(tau_climatology-1)+ maxmoiavail_thisyear(:,:))/tau_climatology
+      minmoiavail_lastyear(:,:) = (minmoiavail_lastyear(:,:)*(tau_climatology-1)+ minmoiavail_thisyear(:,:))/tau_climatology
+      maxgppweek_lastyear(:,:) =( maxgppweek_lastyear(:,:)*(tau_climatology-1)+ maxgppweek_thisyear(:,:))/tau_climatology
+!       maxmoiavail_lastyear(:,:) = maxmoiavail_thisyear(:,:)
+!       minmoiavail_lastyear(:,:) = minmoiavail_thisyear(:,:)
+!       maxgppweek_lastyear(:,:) = maxgppweek_thisyear(:,:)
+
+       gdd0_lastyear(:) = gdd0_thisyear(:)
+
+       precip_lastyear(:) = precip_thisyear(:)
+
+       lm_lastyearmax(:,:) = lm_thisyearmax(:,:)
+
+       maxfpc_lastyear(:,:) = maxfpc_thisyear(:,:)
+
+       !
+       ! 21.2 reset new values
+       !
+
+       maxmoiavail_thisyear(:,:) = zero
+       minmoiavail_thisyear(:,:) = large_value
+
+       maxgppweek_thisyear(:,:) = zero
+
+       gdd0_thisyear(:) = zero
+
+       precip_thisyear(:) = zero
+
+       lm_thisyearmax(:,:) = zero
+
+       maxfpc_thisyear(:,:) = zero
+
+       !
+       ! 21.3 Special treatment for maxfpc. 
+       !
+
+       !
+       ! 21.3.1 Only take into account natural PFTs
+       !
+
+       DO j = 2,nvm
+          IF ( .NOT. natural(j) ) THEN
+             maxfpc_lastyear(:,j) = zero
+          ENDIF
+       ENDDO
+
+       ! 21.3.2 In Stomate, veget is defined as a fraction of ground, not as a fraction 
+       !        of total ground. maxfpc_lastyear will be compared to veget in lpj_light.
+       !        Therefore, we have to transform maxfpc_lastyear.
+
+
+       ! 21.3.3 The sum of the maxfpc_lastyear for natural PFT must not exceed fpc_crit (=.95).
+       !        However, it can slightly exceed this value as not all PFTs reach their maximum 
+       !        fpc at the same time. Therefore, if sum(maxfpc_lastyear) for the natural PFTs
+       !        exceeds fpc_crit, we scale the values of maxfpc_lastyear so that the sum is
+       !        fpc_crit.
+
+       ! calculate the sum of maxfpc_lastyear
+       sumfpc_nat(:) = zero
+       DO j = 2,nvm
+          sumfpc_nat(:) = sumfpc_nat(:) + maxfpc_lastyear(:,j)
+       ENDDO
+
+       ! scale so that the new sum is fpc_crit
+       DO j = 2,nvm 
+          WHERE ( sumfpc_nat(:) .GT. fpc_crit )
+             maxfpc_lastyear(:,j) = maxfpc_lastyear(:,j) * (fpc_crit/sumfpc_nat(:))
+          ENDWHERE
+       ENDDO
+
+    ENDIF  ! EndOfYear
+
+    !
+    ! 22 diagnose herbivore activity, determined through as probability for a leaf to be
+    !    eaten in a day
+    !    Follows McNaughton et al., Nat 341, 142-144, 1989.
+    !
+
+    !
+    ! 22.1 first calculate mean long-term leaf NPP in grid box, mean residence
+    !      time (years) of green tissue (i.e. tissue that will be eaten by 
+    !      herbivores) (crudely approximated: 6 months for seasonal and 2 years 
+    !      for evergreen) and mean length of growing season (6 months for 
+    !      seasonal and 1 year for evergreen).
+    !
+
+    nlflong_nat(:) = zero
+    weighttot(:) = zero
+    green_age(:) = zero
+    !
+    DO j = 2,nvm
+       !
+       IF ( natural(j) ) THEN
+          !
+          weighttot(:) = weighttot(:) + lm_lastyearmax(:,j)
+          nlflong_nat(:) = nlflong_nat(:) + npp_longterm(:,j) * leaf_frac
+          !
+          IF ( pheno_crit%pheno_model(j) .EQ. 'none' ) THEN
+             green_age(:) = green_age(:) + 2. * lm_lastyearmax(:,j)
+          ELSE
+             green_age(:) = green_age(:) + .5 * lm_lastyearmax(:,j)
+          ENDIF
+          !
+       ENDIF
+       !
+    ENDDO
+    !
+    WHERE ( weighttot(:) .GT. zero )
+       green_age(:) = green_age(:) / weighttot(:)
+    ELSEWHERE
+       green_age(:) = un
+    ENDWHERE
+
+    !
+    ! 22.2 McNaughton et al. give herbivore consumption as a function of annual leaf NPP.
+    !      The annual leaf NPP can give us an idea about the edible biomass:
+    !
+
+    DO j = 2,nvm
+       !
+       IF ( natural(j) ) THEN
+          !
+          WHERE ( nlflong_nat(:) .GT. zero )
+             consumption(:) = hvc1 * nlflong_nat(:) ** hvc2
+             herbivores(:,j) = one_year * green_age(:) * nlflong_nat(:) / consumption(:)
+          ELSEWHERE
+             herbivores(:,j) = 100000.
+          ENDWHERE
+          !
+       ELSE
+          !
+          herbivores(:,j) = 100000.
+          !
+       ENDIF
+       !
+    ENDDO
+    herbivores(:,ibare_sechiba) = zero
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving season'
+
+  END SUBROUTINE season
+
+END MODULE stomate_season
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_soilcarbon.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_soilcarbon.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_soilcarbon.f90	(revision 55)
@@ -0,0 +1,237 @@
+!
+! Soil dynamics. Essentially after Century.
+! FOR THE MOMENT, NO VERTICAL DISCRETISATION !!!!
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_soilcarbon.f90,v 1.7 2009/01/06 17:18:32 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_soilcarbon
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC soilcarbon,soilcarbon_clear
+
+  ! first call
+  LOGICAL, SAVE                                                     :: firstcall = .TRUE.
+
+CONTAINS
+
+
+  SUBROUTINE soilcarbon_clear
+    firstcall=.TRUE.
+  ENDSUBROUTINE soilcarbon_clear
+
+  SUBROUTINE soilcarbon (npts, dt, clay, &
+       soilcarbon_input, control_temp, control_moist, &
+       carbon, &
+       resp_hetero_soil)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                               :: npts
+    ! time step in days
+    REAL(r_std), INTENT(in)                                            :: dt
+    ! clay fraction (between 0 and 1)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                           :: clay
+    ! quantity of carbon going into carbon pools from litter decomposition
+    !   (gC/(m**2 of ground)/day)
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(in)           :: soilcarbon_input
+    ! temperature control of heterotrophic respiration
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(in)                     :: control_temp
+    ! moisture control of heterotrophic respiration
+    REAL(r_std), DIMENSION(npts,nlevs), INTENT(in)                     :: control_moist
+
+    ! 0.2 modified fields
+
+    ! carbon pool: active, slow, or passive, (gC/m**2 of ground)
+    REAL(r_std), DIMENSION(npts,ncarb,nvm), INTENT(inout)        :: carbon
+
+    ! 0.3 output
+
+    ! soil heterotrophic respiration (first in gC/day/m**2 of ground )
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)                :: resp_hetero_soil
+
+    ! 0.4 local
+
+    ! residence time in carbon pools (days)
+    REAL(r_std), SAVE, DIMENSION(ncarb)                                :: carbon_tau
+    ! flux fractions within carbon pools
+    REAL(r_std), DIMENSION(npts,ncarb,ncarb)                           :: frac_carb
+    ! fraction of carbon flux which goes into heterotrophic respiration
+    REAL(r_std), DIMENSION(npts,ncarb)                                 :: frac_resp
+    ! total flux out of carbon pools (gC/m**2)
+    REAL(r_std), DIMENSION(npts,ncarb)                                 :: fluxtot
+    ! fluxes between carbon pools (gC/m**2)
+    REAL(r_std), DIMENSION(npts,ncarb,ncarb)                           :: flux
+    ! for messages
+    CHARACTER*7, DIMENSION(ncarb)                                     :: carbon_str
+    ! Indices
+    INTEGER(i_std)                                                    :: k,kk,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering soilcarbon'
+
+    !
+    ! 1 initializations
+    !
+
+    !
+    ! 1.1 get soil "constants"
+    !
+
+    ! 1.1.1 flux fractions between carbon pools: depend on clay content, recalculated
+    !       each time
+
+    ! 1.1.1.1 from active pool: depends on clay content
+
+    frac_carb(:,iactive,iactive) = zero
+    frac_carb(:,iactive,ipassive) = 0.004
+    frac_carb(:,iactive,islow) = un - (.85-.68*clay(:)) - frac_carb(:,iactive,ipassive)
+
+    ! 1.1.1.2 from slow pool
+
+    frac_carb(:,islow,islow) = .0
+    frac_carb(:,islow,iactive) = .42
+    frac_carb(:,islow,ipassive) = .03
+
+    ! 1.1.1.3 from passive pool
+
+    frac_carb(:,ipassive,ipassive) = .0
+    frac_carb(:,ipassive,iactive) = .45
+    frac_carb(:,ipassive,islow) = .0
+
+
+    IF ( firstcall ) THEN
+
+       ! 1.1.2 residence times in carbon pools (days)
+
+       carbon_tau(iactive) = .149 * one_year        !!!!???? 1.5 years
+       carbon_tau(islow) = 5.48 * one_year          !!!!???? 25 years
+       carbon_tau(ipassive) = 241. * one_year       !!!!???? 1000 years
+
+       !
+       ! 1.2 messages
+       !
+
+       carbon_str(iactive) = 'active'
+       carbon_str(islow) = 'slow'
+       carbon_str(ipassive) = 'passive'
+
+       WRITE(numout,*) 'soilcarbon:'
+
+       WRITE(numout,*) '   > minimal carbon residence time in carbon pools (d):'
+       DO k = 1, ncarb
+          WRITE(numout,*) '       ',carbon_str(k),':',carbon_tau(k)
+       ENDDO
+
+       WRITE(numout,*) '   > flux fractions between carbon pools: depend on clay content'
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.3 set output to zero
+    !
+
+    resp_hetero_soil(:,:) = 0.0
+
+    !
+    ! 2 input into carbon pools
+    !
+
+    carbon(:,:,:) = carbon(:,:,:) + soilcarbon_input(:,:,:) * dt
+
+    !
+    ! 3 fluxes within carbon reservoirs + respiration
+    !
+
+    !
+    ! 3.1 determine fraction of flux that is respiration
+    !     diagonal elements of frac_carb are zero
+    !     VPP killer:
+    !     frac_resp(:,:) = 1. - SUM( frac_carb(:,:,:), DIM=3 )
+    !
+
+    frac_resp(:,:) = un - frac_carb(:,:,iactive) - frac_carb(:,:,islow) - &
+         frac_carb(:,:,ipassive) 
+
+    !
+    ! 3.2 calculate fluxes
+    !
+
+    DO m = 2,nvm
+
+       ! 3.2.1 flux out of pools
+
+       DO k = 1, ncarb
+
+          ! determine total flux out of pool
+          ! shilong060505 for crop multiply tillage factor of decomposition
+          IF ( natural(m) ) THEN
+             fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * &
+                  control_moist(:,ibelow) * control_temp(:,ibelow)
+          ELSEIF ( PFT_name(m)=='          C3           agriculture' ) THEN
+             fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * &
+                  control_moist(:,ibelow) * control_temp(:,ibelow) * 1.2
+          ELSEIF ( PFT_name(m)=='          C4           agriculture' ) THEN
+             fluxtot(:,k) = dt/carbon_tau(k) * carbon(:,k,m) * &
+                  control_moist(:,ibelow) * control_temp(:,ibelow) * 1.4
+          ENDIF
+          ! end edit shilong
+          IF ( k .EQ. iactive ) THEN
+             fluxtot(:,k) = fluxtot(:,k) * ( un - .75 * clay(:) )
+          ENDIF
+
+          ! decrease this carbon pool
+
+          carbon(:,k,m) = carbon(:,k,m) - fluxtot(:,k)
+
+          ! fluxes towards the other pools (k -> kk)
+
+          DO kk = 1, ncarb
+             flux(:,k,kk) = frac_carb(:,k,kk) * fluxtot(:,k)
+          ENDDO
+
+       ENDDO
+
+       ! 3.2.2 respiration
+       !       VPP killer:
+       !       resp_hetero_soil(:,m) = SUM( frac_resp(:,:) * fluxtot(:,:), DIM=2 ) / dt
+
+       resp_hetero_soil(:,m) = &
+            ( frac_resp(:,iactive) * fluxtot(:,iactive) + &
+            frac_resp(:,islow) * fluxtot(:,islow) + &
+            frac_resp(:,ipassive) * fluxtot(:,ipassive)  ) / dt
+
+       ! 3.2.3 add fluxes to active, slow, and passive pools
+       !       VPP killer:
+       !       carbon(:,:,m) = carbon(:,:,m) + SUM( flux(:,:,:), DIM=2 )
+
+       DO k = 1, ncarb
+          carbon(:,k,m) = carbon(:,k,m) + &
+               flux(:,iactive,k) + flux(:,ipassive,k) + flux(:,islow,k)
+       ENDDO
+
+    ENDDO
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving soilcarbon'
+
+  END SUBROUTINE soilcarbon
+
+END MODULE stomate_soilcarbon
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_turnover.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_turnover.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_turnover.f90	(revision 55)
@@ -0,0 +1,705 @@
+! This subroutine calculates:
+! 1-6 : leaf senescence, climatic and as a function of leaf age. New LAI.
+! 7 : herbivores
+! 8 : fruit turnover for trees.
+! 9 : sapwood conversion.
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_turnover.f90,v 1.13 2010/04/06 15:44:01 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_turnover
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC turn, turn_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE turn_clear
+    firstcall=.TRUE.
+  END SUBROUTINE turn_clear
+
+  SUBROUTINE turn (npts, dt, PFTpresent, &
+       herbivores, &
+       maxmoiavail_lastyear, minmoiavail_lastyear, &
+       moiavail_week, moiavail_month, tlong_ref, t2m_month, t2m_week, veget_max, &
+       leaf_age, leaf_frac, age, lai, biomass, &
+       turnover, senescence,turnover_time)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                        :: npts
+    ! time step in days
+    REAL(r_std), INTENT(in)                                     :: dt
+    ! PFT exists
+    LOGICAL, DIMENSION(npts,nvm), INTENT(in)                  :: PFTpresent
+    ! time constant of probability of a leaf to be eaten by a herbivore (days)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: herbivores
+    ! last year's maximum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: maxmoiavail_lastyear
+    ! last year's minimum moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: minmoiavail_lastyear
+    ! "weekly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_week
+    ! "monthly" moisture availability
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: moiavail_month
+    ! "long term" 2 meter reference temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: tlong_ref
+    ! "monthly" 2-meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_month
+    ! "weekly" 2 meter temperatures (K)
+    REAL(r_std), DIMENSION(npts), INTENT(in)                    :: t2m_week
+    ! "maximal" coverage fraction of a PFT (LAI -> infinity) on ground
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)               :: veget_max
+
+    ! 0.2 modified fields
+
+    ! age of the leaves (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age
+    ! fraction of leaves in leaf age class 
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
+    ! age (years)
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: age
+    ! leaf area index
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(in)            :: lai
+    ! biomass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(inout)     :: biomass
+    ! turnover_time  of grasse
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(inout)            :: turnover_time
+
+    ! 0.3 output
+
+    ! Turnover rates (gC/day/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts,nvm,nparts), INTENT(out)       :: turnover
+    ! is the plant senescent?
+    !   (interesting only for deciduous trees: carbohydrate reserve)
+    LOGICAL, DIMENSION(npts,nvm), INTENT(out)                 :: senescence
+
+    ! 0.4 local
+
+!!$    ! minimum leaf age for senescence (d)
+!!$    REAL(r_std), PARAMETER                                      :: min_leaf_age = 30.
+    ! mean age of the leaves (days)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: leaf_meanage
+    ! Intermediate variable for turnover
+    REAL(r_std), DIMENSION(npts)                                :: dturnover
+    ! critical moisture availability, function of last year's moisture availability
+    REAL(r_std), DIMENSION(npts)                                :: moiavail_crit
+    ! long term annual mean temperature, C
+    REAL(r_std), DIMENSION(npts)                                :: tl
+    ! critical senescence temperature, function of long term annual temperature (K)
+    REAL(r_std), DIMENSION(npts)                                :: t_crit
+    ! shed the remaining leaves?
+    LOGICAL, DIMENSION(npts)                                   :: shed_rest
+    ! Sapwood conversion (gC/day(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: sapconv
+    ! old heartwood mass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: hw_old
+    ! new heartwood mass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: hw_new
+    ! old leaf mass (gC/(m**2 of ground))
+    REAL(r_std), DIMENSION(npts)                                :: lm_old
+    ! leaf mass change for each age class
+    REAL(r_std), DIMENSION(npts,nleafages)                      :: delta_lm
+    ! turnover rate
+    REAL(r_std), DIMENSION(npts)                                :: turnover_rate
+    ! critical leaf age (d)
+    REAL(r_std), DIMENSION(npts,nvm)                           :: leaf_age_crit
+    ! instantaneous turnover time
+    REAL(r_std), DIMENSION(npts,nvm)                           :: new_turnover_time
+    ! Index
+    INTEGER(i_std)                                             :: j,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering turnover'
+
+    !
+    ! 1 messages
+    !
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'turnover:'
+
+       WRITE(numout,*) ' > minimum mean leaf age for senescence (d): ',pheno_crit%min_leaf_age_for_senescence
+
+       firstcall = .FALSE.
+
+
+    ENDIF
+
+    !
+    ! 2 Initializations 
+    !
+
+    !
+    ! 2.1 set output to zero
+    !
+
+    turnover(:,:,:) = zero
+    new_turnover_time=zero
+    senescence(:,:) = .FALSE.
+
+    !
+    ! 2.2 mean leaf age. Should actually be recalculated at the end of this routine,
+    !     but it does not change too fast.
+    !
+
+    leaf_meanage(:,:) = 0.0
+
+    DO m = 1, nleafages
+       leaf_meanage(:,:) = leaf_meanage(:,:) + leaf_age(:,:,m) * leaf_frac(:,:,m)
+    ENDDO
+
+    !
+    ! 3 different types of "climatic" leaf senescence
+    !   does not change age structure. 
+    !
+
+    DO j = 2,nvm
+
+       !
+       ! 3.1 determine if there is climatic senescence
+       !
+
+       SELECT CASE ( pheno_crit%senescence_type(j) )
+
+       CASE ( 'cold' )
+
+          ! 3.1.1 summergreen species:
+          !       monthly temperature low and temperature tendency negative ?
+
+          ! critical temperature for senescence may depend on long term annual mean temperature
+          tl(:) = tlong_ref(:) - ZeroCelsius
+          t_crit(:) = ZeroCelsius + pheno_crit%senescence_temp(j,1) + &
+               tl(:) * pheno_crit%senescence_temp(j,2) + &
+               tl(:)*tl(:) * pheno_crit%senescence_temp(j,3)
+
+          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. &
+               ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
+               ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) )
+
+             senescence(:,j) = .TRUE.
+
+          ENDWHERE
+
+       CASE ( 'dry' )
+
+          ! 3.1.2 raingreen species:
+          !       does moisture availability drop below critical level?
+
+          moiavail_crit(:) = &
+               MIN( MAX( minmoiavail_lastyear(:,j) + pheno_crit%hum_frac(j) * &
+               ( maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
+               pheno_crit%senescence_hum(j) ), &
+               pheno_crit%nosenescence_hum(j) )
+
+          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. &
+               ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
+               ( moiavail_week(:,j) .LT. moiavail_crit(:) ) )
+
+             senescence(:,j) = .TRUE.
+
+          ENDWHERE
+
+       CASE ( 'mixed' )
+
+          ! 3.1.3 mixed criterion:
+          !       moisture availability drops below critical level, or
+          !       monthly temperature low and temperature tendency negative
+          moiavail_crit(:) = &
+               MIN( MAX( minmoiavail_lastyear(:,j) + pheno_crit%hum_frac(j) * &
+               ( maxmoiavail_lastyear(:,j) - minmoiavail_lastyear(:,j) ), &
+               pheno_crit%senescence_hum(j) ), &
+               pheno_crit%nosenescence_hum(j) )
+          tl(:) = tlong_ref(:) - ZeroCelsius
+          t_crit(:) = ZeroCelsius + pheno_crit%senescence_temp(j,1) + &
+               tl(:) * pheno_crit%senescence_temp(j,2) + &
+               tl(:)*tl(:) * pheno_crit%senescence_temp(j,3)
+          IF ( tree(j) ) THEN
+
+             ! critical temperature for senescence may depend on long term annual mean temperature
+             WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. &
+                  ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) ) .AND. &
+                  ( ( moiavail_week(:,j) .LT. moiavail_crit(:) ) .OR. &
+                  ( ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) ) ) )
+                senescence(:,j) = .TRUE.
+             ENDWHERE
+          ELSE
+             new_turnover_time(:,j)=pheno_crit%max_turnover_time(j)+20
+             WHERE ((moiavail_week(:,j) .LT. moiavail_month(:,j))&
+                  .AND. (moiavail_week(:,j) .LT. pheno_crit%nosenescence_hum(j)))
+                new_turnover_time(:,j)=pheno_crit%max_turnover_time(j) * &
+                     (1.-pheno_crit%nosenescence_hum(j)+moiavail_week(:,j)) * &
+                     (1.-pheno_crit%nosenescence_hum(j)+moiavail_week(:,j)) + &
+                     pheno_crit%min_turnover_time(j)
+                !            new_turnover_time(:,j)=pheno_crit%max_turnover_time(j) * &
+                !                   moiavail_week(:,j)/ pheno_crit%nosenescence_hum(j) + &
+                !                   pheno_crit%min_turnover_time(j)
+             ENDWHERE
+             !         WHERE ((t2m_month(:) .LT. t_crit(:)+5) .AND. ( t2m_week(:) .LT. t2m_month(:) ))
+             !            new_turnover_time(:,j)=new_turnover_time(:,j)*((t2m_month(:)-t_crit(:))/5*0.4+0.6)
+             !         ENDWHERE
+             !         WHERE (new_turnover_time(:,j) .LT.  pheno_crit%min_turnover_time(j))
+             !            new_turnover_time(:,j)=pheno_crit%min_turnover_time(j)
+             !         ENDWHERE
+
+             WHERE (new_turnover_time(:,j) .GT. turnover_time(:,j)*1.1)
+                new_turnover_time(:,j)=pheno_crit%max_turnover_time(j)+20
+             ENDWHERE
+!!$            WHERE  ( ( t2m_month(:) .LT. t_crit(:) ) .AND. ( t2m_week(:) .LT. t2m_month(:) ) &
+!!$                 &   .AND. ( leaf_meanage(:,j) .GT. pheno_crit%min_leaf_age_for_senescence(j) )) 
+!!$              new_turnover_time(:,j)=pheno_crit%min_turnover_time(j)
+!!$            ENDWHERE
+             !           print *,'t_crit=',t_crit
+
+
+             turnover_time(:,j)=(turnover_time(:,j)*10./dt+new_turnover_time(:,j))/(10./dt+1.)
+
+          ENDIF
+
+       CASE ( 'none' )
+
+          ! evergreen species: no climatic senescence
+
+       CASE default
+
+          WRITE(numout,*) 'turnover: don''t know how to treat this PFT.'
+          WRITE(numout,*) '  number: ',j
+          WRITE(numout,*) '  senescence type: ',pheno_crit%senescence_type(j)
+          STOP
+
+       END SELECT
+
+       !
+       ! 3.2 drop leaves and roots, plus stems and fruits for grasses
+       !
+
+       IF ( tree(j) ) THEN
+
+          ! 3.2.1 trees
+
+          WHERE ( senescence(:,j) )
+
+             turnover(:,j,ileaf) = biomass(:,j,ileaf) * dt / pheno_crit%leaffall(j)
+             turnover(:,j,iroot) = biomass(:,j,iroot) * dt / pheno_crit%leaffall(j)
+
+             biomass(:,j,ileaf) = biomass(:,j,ileaf) - turnover(:,j,ileaf)
+             biomass(:,j,iroot) = biomass(:,j,iroot) - turnover(:,j,iroot)
+
+          ENDWHERE
+
+       ELSE
+
+          ! 3.2.2 grasses      
+          WHERE (turnover_time(:,j) .LT. pheno_crit%max_turnover_time(j)) 
+             turnover(:,j,ileaf) = biomass(:,j,ileaf) * dt / turnover_time(:,j)
+             turnover(:,j,isapabove) = biomass(:,j,isapabove) * dt / turnover_time(:,j)
+             turnover(:,j,iroot) = biomass(:,j,iroot) * dt / turnover_time(:,j) 
+             turnover(:,j,ifruit) = biomass(:,j,ifruit) * dt / turnover_time(:,j)
+          ELSEWHERE
+             turnover(:,j,ileaf)=zero
+             turnover(:,j,isapabove) =zero
+             turnover(:,j,iroot) = zero
+             turnover(:,j,ifruit) =zero
+          ENDWHERE
+          biomass(:,j,ileaf) = biomass(:,j,ileaf) - turnover(:,j,ileaf)
+          biomass(:,j,isapabove) = biomass(:,j,isapabove) - turnover(:,j,isapabove)
+          biomass(:,j,iroot) = biomass(:,j,iroot) - turnover(:,j,iroot)
+          biomass(:,j,ifruit) = biomass(:,j,ifruit) - turnover(:,j,ifruit)
+
+       ENDIF      ! tree/grass
+
+    ENDDO        ! loop over PFTs
+
+    !
+    ! 4 At a certain age, leaves fall off, even if the climate would allow a green plant
+    !     all year round.
+    !   Decay rate varies with leaf age.
+    !   Roots, fruits (and stems) follow leaves.
+    !   Note that plant is not declared senescent in this case (important for allocation:
+    !   if the plant loses leaves because of their age, it can renew them).
+    !
+
+    DO j = 2,nvm
+
+       ! save old leaf mass
+       lm_old(:) = biomass(:,j,ileaf)
+
+       ! initialize leaf mass change in age class
+       delta_lm(:,:) = 0.0
+
+       IF ( tree(j) ) THEN
+
+          !
+          ! 4.1 trees: leaves, roots, fruits
+          !            roots and fruits follow leaves.
+          !
+
+          ! 4.1.1 critical age: prescribed for trees
+
+          leaf_age_crit(:,j) = pheno_crit%leafagecrit(j)
+
+          ! 4.1.2 loop over leaf age classes
+
+          DO m = 1, nleafages
+             turnover_rate(:) = zero
+             WHERE ( leaf_age(:,j,m) .GT. leaf_age_crit(:,j)/2. )
+
+                turnover_rate(:) =  &
+                     MIN( 0.99_r_std, dt / ( leaf_age_crit(:,j) * &
+                     ( leaf_age_crit(:,j) / leaf_age(:,j,m) )**4._r_std ) )
+
+                dturnover(:) = biomass(:,j,ileaf) * leaf_frac(:,j,m) * turnover_rate(:)
+                turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
+                biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
+
+                ! save leaf mass change
+                delta_lm(:,m) = - dturnover(:)
+
+                dturnover(:) = biomass(:,j,iroot) * leaf_frac(:,j,m) * turnover_rate(:)
+                turnover(:,j,iroot) = turnover(:,j,iroot) + dturnover(:)
+                biomass(:,j,iroot) = biomass(:,j,iroot) - dturnover(:)
+
+                dturnover(:) = biomass(:,j,ifruit) * leaf_frac(:,j,m) * turnover_rate(:)
+                turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
+                biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
+
+             ENDWHERE
+
+          ENDDO
+
+       ELSE
+
+          !
+          ! 4.2 grasses: leaves, roots, fruits, sap.
+          !              roots, fruits, and sap follow leaves.
+          !
+
+          ! 4.2.1 critical leaf age depends on long-term temperature:
+          !       generally, lower turnover in cooler climates.
+
+          leaf_age_crit(:,j) = &
+               MIN( pheno_crit%leafagecrit(j) * 1.5_r_std , &
+               MAX( pheno_crit%leafagecrit(j) * 0.75_r_std, &
+               pheno_crit%leafagecrit(j) - 10._r_std * &
+               ( tlong_ref(:)-ZeroCelsius-20._r_std ) ) )
+
+          ! 4.2.2 loop over leaf age classes
+
+          DO m = 1, nleafages
+
+             WHERE ( leaf_age(:,j,m) .GT. leaf_age_crit(:,j)/2. )
+
+                turnover_rate(:) =  &
+                     MIN( 0.99_r_std, dt / ( leaf_age_crit(:,j) * &
+                     ( leaf_age_crit(:,j) / leaf_age(:,j,m) )**4._r_std ) )
+
+                dturnover(:) = biomass(:,j,ileaf) * leaf_frac(:,j,m) * turnover_rate(:)
+                turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
+                biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
+
+                ! save leaf mass change
+                delta_lm(:,m) = - dturnover(:)
+
+                dturnover(:) = biomass(:,j,isapabove) * leaf_frac(:,j,m) * turnover_rate(:)
+                turnover(:,j,isapabove) = turnover(:,j,isapabove) + dturnover(:)
+                biomass(:,j,isapabove) = biomass(:,j,isapabove) - dturnover(:)
+
+                dturnover(:) = biomass(:,j,iroot) * leaf_frac(:,j,m) * turnover_rate(:)
+                turnover(:,j,iroot) = turnover(:,j,iroot) + dturnover(:)
+                biomass(:,j,iroot) = biomass(:,j,iroot) - dturnover(:)
+
+                dturnover(:) = biomass(:,j,ifruit) * leaf_frac(:,j,m) * turnover_rate(:)
+                turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
+                biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
+
+             ENDWHERE
+
+
+          ENDDO
+
+       ENDIF       ! tree/grass ?
+
+       !
+       ! 4.3 recalculate fraction in each leaf age class
+       !     new fraction = new leaf mass of that fraction / new total leaf mass
+       !                  = ( old fraction*old total leaf mass + biomass change of that fraction ) /
+       !                    new total leaf mass
+       !
+
+       DO m = 1, nleafages
+
+          WHERE ( biomass(:,j,ileaf) .GT. 0.0 )
+             leaf_frac(:,j,m) = ( leaf_frac(:,j,m)*lm_old(:) + delta_lm(:,m) ) / biomass(:,j,ileaf)
+          ELSEWHERE
+             leaf_frac(:,j,m) = zero
+          ENDWHERE
+
+       ENDDO
+
+    ENDDO         ! loop over PFTs
+
+    !
+    ! 5 new (provisional) lai
+    !
+
+    !    lai(:,ibare_sechiba) = zero
+    !    DO j = 2, nvm
+    !        lai(:,j) = biomass(:,j,ileaf) * sla(j)
+    !    ENDDO
+
+    !
+    ! 6 definitely drop leaves if very low leaf mass during senescence.
+    !   Also drop fruits and loose fine roots.
+    !   Set lai to zero if necessary
+    !   Check whether leaf regrowth is immediately allowed.
+    !
+
+    DO j = 2,nvm
+
+       shed_rest(:) = .FALSE.
+
+       !
+       ! 6.1 deciduous trees
+       !
+
+       IF ( tree(j) .AND. ( pheno_crit%senescence_type(j) .NE. 'none' ) ) THEN
+
+          ! check whether we shed the remaining leaves
+
+          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. senescence(:,j) .AND. &
+               ( biomass(:,j,ileaf) .LT. (pheno_crit%lai_initmin(j) / 2.)/sla(j) )             )
+
+             shed_rest(:) = .TRUE.
+
+             turnover(:,j,ileaf) = turnover(:,j,ileaf) + biomass(:,j,ileaf)
+             turnover(:,j,iroot) = turnover(:,j,iroot) + biomass(:,j,iroot)
+             turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit)
+
+             biomass(:,j,ileaf) = zero
+             biomass(:,j,iroot) = zero
+             biomass(:,j,ifruit) = zero
+
+
+
+             ! reset leaf age
+             leaf_meanage(:,j) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+       !
+       ! 6.2 grasses: also convert stems
+       !
+
+       IF ( .NOT. tree(j) ) THEN
+
+          ! Shed the remaining leaves if LAI very low.
+
+          WHERE ( ( biomass(:,j,ileaf) .GT. zero ) .AND. senescence(:,j) .AND. &
+               (  biomass(:,j,ileaf) .LT. (pheno_crit%lai_initmin(j) / 2.)/sla(j) ))
+
+             shed_rest(:) = .TRUE.
+
+             turnover(:,j,ileaf) = turnover(:,j,ileaf) + biomass(:,j,ileaf)
+             turnover(:,j,isapabove) = turnover(:,j,isapabove) + biomass(:,j,isapabove)
+             turnover(:,j,iroot) = turnover(:,j,iroot) + biomass(:,j,iroot)
+             turnover(:,j,ifruit) = turnover(:,j,ifruit) + biomass(:,j,ifruit)
+
+             biomass(:,j,ileaf) = zero
+             biomass(:,j,isapabove) = zero
+             biomass(:,j,iroot) = zero
+             biomass(:,j,ifruit) = zero
+
+
+
+             ! reset leaf age
+             leaf_meanage(:,j) = zero
+
+          ENDWHERE
+
+       ENDIF
+
+       !
+       ! 6.3 reset leaf age structure
+       !
+
+       DO m = 1, nleafages
+
+          WHERE ( shed_rest(:) )
+
+             leaf_age(:,j,m) = zero
+             leaf_frac(:,j,m) = zero
+
+          ENDWHERE
+
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 7 Elephants, cows, gazelles. No lions.
+    !   Does not modify leaf age structure.
+    !
+
+    IF ( ok_herbivores ) THEN
+
+       ! herbivore activity allowed. Eat when there are leaves. Otherwise,
+       ! there won't be many fruits anyway.
+
+       DO j = 2,nvm
+
+          IF ( tree(j) ) THEN
+
+             ! trees: only leaves and fruits are affected
+
+             WHERE ( biomass(:,j,ileaf) .GT. zero )
+                ! added by shilong
+                WHERE (herbivores(:,j).GT. zero)
+                   dturnover(:) = biomass(:,j,ileaf) * dt / herbivores(:,j)
+                   turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
+                   biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
+
+                   dturnover(:) = biomass(:,j,ifruit) * dt / herbivores(:,j)
+                   turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
+                   biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
+                ENDWHERE
+             ENDWHERE
+
+          ELSE
+
+             ! grasses: the whole biomass above the ground: leaves, fruits, stems
+
+             WHERE ( biomass(:,j,ileaf) .GT. zero )
+                ! added by shilong
+                WHERE (herbivores(:,j) .GT. zero)
+                   dturnover(:) = biomass(:,j,ileaf) * dt / herbivores(:,j)
+                   turnover(:,j,ileaf) = turnover(:,j,ileaf) + dturnover(:)
+                   biomass(:,j,ileaf) = biomass(:,j,ileaf) - dturnover(:)
+
+                   dturnover(:) = biomass(:,j,isapabove) * dt / herbivores(:,j)
+                   turnover(:,j,isapabove) = turnover(:,j,isapabove) + dturnover(:)
+                   biomass(:,j,isapabove) = biomass(:,j,isapabove) - dturnover(:)
+
+                   dturnover(:) = biomass(:,j,ifruit) * dt / herbivores(:,j)
+                   turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
+                   biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
+                ENDWHERE
+
+             ENDWHERE
+
+          ENDIF  ! tree/grass?
+
+       ENDDO    ! loop over PFTs
+
+    ENDIF
+
+    !
+    ! 8 fruit turnover for trees
+    !
+
+    DO j = 2,nvm
+
+       IF ( tree(j) ) THEN
+
+          !SZ correction of a mass destroying bug
+          dturnover(:) = biomass(:,j,ifruit) * dt / tau_fruit(j)
+          turnover(:,j,ifruit) = turnover(:,j,ifruit) + dturnover(:)
+          biomass(:,j,ifruit) = biomass(:,j,ifruit) - dturnover(:)
+!!$        turnover(:,j,ifruit) = biomass(:,j,ifruit) * dt / tau_fruit(j)
+!!$        biomass(:,j,ifruit) = biomass(:,j,ifruit) - turnover(:,j,ifruit)
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! 9 Conversion of sapwood to heartwood
+    !   This is not added to "turnover" as the biomass is not lost!
+    !
+
+    DO j = 2,nvm
+
+       IF ( tree(j) ) THEN
+
+          ! for age calculations
+
+          IF ( .NOT. control%ok_dgvm ) THEN
+             hw_old(:) = biomass(:,j,iheartabove) + biomass(:,j,iheartbelow)
+          ENDIF
+
+          !
+          ! 9.1 Calculate the rate of conversion and update masses
+          !
+
+          ! above the ground
+
+          sapconv(:) = biomass(:,j,isapabove) * dt / tau_sap(j)
+          biomass(:,j,isapabove) = biomass(:,j,isapabove) - sapconv(:)
+          biomass(:,j,iheartabove) =  biomass(:,j,iheartabove) + sapconv(:)
+
+          ! below the ground
+
+          sapconv(:) = biomass(:,j,isapbelow) * dt / tau_sap(j)
+          biomass(:,j,isapbelow) = biomass(:,j,isapbelow) - sapconv(:)
+          biomass(:,j,iheartbelow) =  biomass(:,j,iheartbelow) + sapconv(:)
+
+
+          !
+          ! 9.2 If vegetation is not dynamic, identify the age of the heartwood 
+          !     to the age of the whole tree (otherwise, the age of the tree is
+          !     treated in the establishment routine).
+          !     Creation of new heartwood decreases the age of the plant.
+          !
+
+          IF ( .NOT. control%ok_dgvm ) THEN
+
+             hw_new(:) = biomass(:,j,iheartabove) + biomass(:,j,iheartbelow)
+
+             WHERE ( hw_new(:) .GT. zero )
+
+                age(:,j) = age(:,j) * hw_old(:)/hw_new(:)
+
+             ENDWHERE
+
+          ENDIF
+
+       ENDIF
+
+    ENDDO
+
+    !
+    ! history
+    !
+
+    CALL histwrite (hist_id_stomate, 'LEAF_AGE', itime, &
+         leaf_meanage, npts*nvm, horipft_index)
+    CALL histwrite (hist_id_stomate, 'HERBIVORES', itime, &
+         herbivores, npts*nvm, horipft_index)
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving turnover'
+
+  END SUBROUTINE turn
+
+END MODULE stomate_turnover
Index: tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_vmax.f90
===================================================================
--- tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_vmax.f90	(revision 55)
+++ tags/ORCHIDEE_1_9_5_1/ORCHIDEE/src_stomate/stomate_vmax.f90	(revision 55)
@@ -0,0 +1,286 @@
+! calculates the leaf efficiency
+!
+! $Header: /home/ssipsl/CVSREP/ORCHIDEE/src_stomate/stomate_vmax.f90,v 1.11 2010/04/06 15:44:01 ssipsl Exp $
+! IPSL (2006)
+!  This software is governed by the CeCILL licence see ORCHIDEE/ORCHIDEE_CeCILL.LIC
+!
+MODULE stomate_vmax
+
+  ! modules used:
+
+  USE ioipsl
+  USE stomate_constants
+  USE constantes_veg
+
+  IMPLICIT NONE
+
+  ! private & public routines
+
+  PRIVATE
+  PUBLIC vmax, vmax_clear
+
+  ! first call
+  LOGICAL, SAVE                                              :: firstcall = .TRUE.
+
+CONTAINS
+
+  SUBROUTINE vmax_clear
+    firstcall=.TRUE.
+  END SUBROUTINE vmax_clear
+
+  SUBROUTINE vmax (npts, dt, &
+       leaf_age, leaf_frac, &
+       vcmax, vjmax)
+
+    !
+    ! 0 declarations
+    !
+
+    ! 0.1 input
+
+    ! Domain size
+    INTEGER(i_std), INTENT(in)                                        :: npts
+    ! time step of Stomate in days
+    REAL(r_std), INTENT(in)                                     :: dt
+
+    ! 0.2 modified fields
+
+    ! leaf age (days)
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_age
+    ! fraction of leaves in leaf age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages), INTENT(inout)  :: leaf_frac
+
+    ! 0.3 output
+
+    ! Maximum rate of carboxylation
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: vcmax
+    ! Maximum rate of RUbp regeneration
+    REAL(r_std), DIMENSION(npts,nvm), INTENT(out)              :: vjmax
+
+    ! 0.4 local
+
+    ! offset (minimum relative vcmax)
+    REAL(r_std), PARAMETER                                      :: vmax_offset = 0.3
+    ! leaf age at which vmax attains vcmax_opt (in fraction of critical leaf age)
+    REAL(r_std), PARAMETER                                      :: leafage_firstmax = 0.03
+    ! leaf age at which vmax falls below vcmax_opt (in fraction of critical leaf age)
+    REAL(r_std), PARAMETER                                      :: leafage_lastmax = 0.5
+    ! leaf age at which vmax attains its minimum (in fraction of critical leaf age)
+    REAL(r_std), PARAMETER                                      :: leafage_old = un
+    ! leaf efficiency (vcmax/vcmax_opt)
+    REAL(r_std), DIMENSION(npts)                                :: leaf_efficiency
+    ! change of fraction of leaves in age class
+    REAL(r_std), DIMENSION(npts,nvm,nleafages)                 :: d_leaf_frac
+    ! new leaf age (d)
+    REAL(r_std), DIMENSION(npts,nleafages)                      :: leaf_age_new
+    ! sum of leaf age fractions, for normalization
+    REAL(r_std), DIMENSION(npts)                                :: sumfrac
+    ! relative leaf age (age/critical age)
+    REAL(r_std), DIMENSION(npts)                                :: rel_age
+    ! Index
+    INTEGER(i_std)                                              :: j,m
+
+    ! =========================================================================
+
+    IF (bavard.GE.3) WRITE(numout,*) 'Entering vmax'
+
+    !
+    ! 1 Initialization
+    !
+
+    !
+    ! 1.1 first call: info about flags and parameters.
+    !
+
+    IF ( firstcall ) THEN
+
+       WRITE(numout,*) 'vmax:'
+
+       WRITE(numout,*) '   > offset (minimum vcmax/vmax_opt):' , vmax_offset
+       WRITE(numout,*) '   > relative leaf age at which vmax attains vcmax_opt:', leafage_firstmax
+       WRITE(numout,*) '   > relative leaf age at which vmax falls below vcmax_opt:', leafage_lastmax
+       WRITE(numout,*) '   > relative leaf age at which vmax attains its minimum:', leafage_old
+
+       firstcall = .FALSE.
+
+    ENDIF
+
+    !
+    ! 1.2 initialize output
+    !
+
+    vcmax(:,:) = zero
+    vjmax(:,:) = zero
+
+    !
+    ! 2 leaf age: general increase and turnover between age classes.
+    !
+
+    !
+    ! 2.1 increase leaf age
+    !
+
+    DO m = 1, nleafages
+
+       DO j = 2,nvm
+          WHERE ( leaf_frac(:,j,m) .GT. min_stomate )
+
+             leaf_age(:,j,m) = leaf_age(:,j,m) + dt
+             
+          ENDWHERE
+       ENDDO
+
+    ENDDO
+
+    !
+    ! 2.2 turnover between leaf age classes
+    !     d_leaf_frac(:,:,m) = what leaves m-1 and goes into m
+    !
+
+    DO j = 2,nvm
+
+       ! 2.2.1 fluxes
+
+       ! nothing goes into first age class
+       d_leaf_frac(:,j,1) = zero
+
+       ! from m-1 to m
+       DO m = 2, nleafages 
+
+          d_leaf_frac(:,j,m) = leaf_frac(:,j,m-1) * dt/leaf_timecst(j)
+
+       ENDDO
+
+       ! 2.2.2 new leaf age in class
+       !       new age = ( old age * old fraction + fractional increase * age of source ) /
+       !                 new fraction
+
+       leaf_age_new(:,:) = zero
+
+       DO m = 2, nleafages-1
+          !      DO m=2, nleafages
+
+          WHERE ( d_leaf_frac(:,j,m) .GT. min_stomate )
+
+             leaf_age_new(:,m) = ( ( (leaf_frac(:,j,m)- d_leaf_frac(:,j,m+1)) * leaf_age(:,j,m) )  + &
+                  ( d_leaf_frac(:,j,m) * leaf_age(:,j,m-1) ) ) / &
+                  ( leaf_frac(:,j,m) + d_leaf_frac(:,j,m)- d_leaf_frac(:,j,m+1) )
+
+             !           leaf_age_new(:,m) = ( ( leaf_frac(:,j,m) * leaf_age(:,j,m) )  + &
+             !                                ( d_leaf_frac(:,j,m) * leaf_age(:,j,m-1) ) ) / &
+             !                              ( leaf_frac(:,j,m) + d_leaf_frac(:,j,m) )
+
+          ENDWHERE
+
+       ENDDO       ! Loop over age classes
+
+       WHERE ( d_leaf_frac(:,j,nleafages) .GT. min_stomate )
+
+          leaf_age_new(:,nleafages) = ( ( leaf_frac(:,j,nleafages) * leaf_age(:,j,nleafages) )  + &
+               ( d_leaf_frac(:,j,nleafages) * leaf_age(:,j,nleafages-1) ) ) / &
+               ( leaf_frac(:,j,nleafages) + d_leaf_frac(:,j,nleafages) )
+
+       ENDWHERE
+
+       DO m = 2, nleafages
+
+          WHERE ( d_leaf_frac(:,j,m) .GT. min_stomate )
+
+             leaf_age(:,j,m) = leaf_age_new(:,m)
+
+          ENDWHERE
+
+       ENDDO       ! Loop over age classes
+
+       ! 2.2.3 calculate new fraction
+
+       DO m = 2, nleafages
+
+          ! where the change comes from
+          leaf_frac(:,j,m-1) = leaf_frac(:,j,m-1) - d_leaf_frac(:,j,m)
+
+          ! where it goes to
+          leaf_frac(:,j,m) = leaf_frac(:,j,m) + d_leaf_frac(:,j,m)
+
+       ENDDO
+
+       ! 2.2.4 renormalize fractions in order to prevent accumulation 
+       !       of numerical errors
+
+       ! correct small negative values
+
+       DO m = 1, nleafages
+          leaf_frac(:,j,m) = MAX( zero, leaf_frac(:,j,m) )
+       ENDDO
+
+       ! total of fractions, should be very close to one where there is leaf mass
+
+       sumfrac(:) = zero
+
+       DO m = 1, nleafages
+
+          sumfrac(:) = sumfrac(:) + leaf_frac(:,j,m)
+
+       ENDDO
+
+       ! normalize
+
+       DO m = 1, nleafages
+
+          WHERE ( sumfrac(:) .GT. min_stomate )
+
+             leaf_frac(:,j,m) = leaf_frac(:,j,m) / sumfrac(:) 
+
+          ELSEWHERE
+
+             leaf_frac(:,j,m) = zero
+
+          ENDWHERE
+
+       ENDDO
+
+    ENDDO         ! Loop over PFTs
+
+    !
+    ! 3 calculate vmax as a function of the age
+    !
+
+    DO j = 2,nvm
+
+       vcmax(:,j) = zero
+       vjmax(:,j) = zero
+
+       ! sum up over the different age classes
+
+       DO m = 1, nleafages
+
+          !
+          ! 3.1 efficiency in each of the age classes
+          !     increases from 0 to 1 at the beginning (rel_age < leafage_firstmax), stays 1
+          !     until rel_age = leafage_lastmax, then decreases to vmax_offset at 
+          !     rel_age = leafage_old, then stays at vmax_offset.
+          !
+
+          rel_age(:) = leaf_age(:,j,m) / pheno_crit%leafagecrit(j)
+
+          leaf_efficiency(:) = MAX( vmax_offset, MIN( 1._r_std, &
+               vmax_offset + (1._r_std-vmax_offset) * rel_age(:) / leafage_firstmax, &
+               1._r_std - (1._r_std-vmax_offset) * ( rel_age(:) - leafage_lastmax ) / &
+               ( leafage_old - leafage_lastmax ) ) )
+
+          !
+          ! 3.2 add to mean vmax
+          !
+
+          vcmax(:,j) = vcmax(:,j) + vcmax_opt(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
+          vjmax(:,j) = vjmax(:,j) + vjmax_opt(j) * leaf_efficiency(:) * leaf_frac(:,j,m)
+
+       ENDDO     ! loop over age classes
+
+    ENDDO       ! loop over PFTs
+
+    IF (bavard.GE.4) WRITE(numout,*) 'Leaving vmax'
+
+  END SUBROUTINE vmax
+
+END MODULE stomate_vmax
